*COMDECK BASE                                                           LEP00010
      COMMON/BASE/NMAX,JMAX,KMAX,LMAX,JM,KM,LM,DT,GAMMA,GAMI,SMU,FSMACH LEP00020
     1  ,DX1,DY1,DZ1,ND,ND2,FV(5),FD(5),HD,ALP,GD,OMEGA,HDX,HDY,HDZ     LEP00030
     2,RM,CNBR,PI,ITR,INVISC,LAMIN,NP,INT1,INT2,INT3                    LEP00040
     3,KPLANE,ITW,TW,WMDOT,L1BC,LMAXBC,LU,LL,JWL1,KU,WTFAC,JMAXBC       LEP00050
     4,J1BC,JB,HTOT(32,32),PTOT(32,32),VOU(32,32),WOU(32,32),KMAXBC,KAL,LEP00060
     5K1BC,DTFAC,RESID,NK,AREF,LW,KW,JL1WL,JL1WU,JK1WL,JK1WU,JLW,JKW    LEP00070
     6,SM0,XLSKM2,XLS22,ZLSKM2,ZLS22,ENTGD(32),ENTGD1(32,5),SIGJMX,JTJ, LEP00080
     7KTJ,LTJ,IGNCAL,NRES,NC,NC1,TAU,NSTEP,JT,KT,LT,SIGMAX,GF(5),RESIDS LEP00090
     8,NKLP,NLROW,NLSKIP,KL2,INXBC,RMACH,DTMAX,KVIS,LVIS,KLVIS          LEP00100
      COMMON/GEO/NB1,NB2,RFRONT,RMAX,XR,XMAX,DRAD,DXC                   LEP00110
      COMMON/READ/NRST,IWRIT,NGRI,NROUT                                 LEP00120
      COMMON/VIS/RE,PR                                                  LEP00130
*COMDECK BTRID                                                          LEP00140
      COMMON/BTRID/A(32,5,5),B(32,5,5),C(32,5,5),D(32,5,5),F(32,5)      LEP00150
*COMDECK GLOB                                                           LEP00160
      COMMON/GLOB/CWFAC,CW,JTT,AT,DINJMX(5),DINJ1(5),ENTB(32,5,2)       LEP00170
     1   ,Q6L1,Q6LMAX,IGFSUR,ENTD(32)                                   LEP00180
*COMDECK RHSBCC                                                         LEP00190
      COMMON/RHSBCC/IW,KUORLU,LORKMX,KORLMX,LMORKM,LLORKL,LUORKU,LKMXBC LEP00200
     1,KLMXBC,LK1BC,KL1BC,LORKW,KORLW,JLK1WL,JLK1WU,JKL1WL,JKL1WU,JLKW  LEP00210
     1,JKLW,DZORDY,GKPR,PRTR,I,J,KLORLL                                 LEP00220
*COMDECK SHOCKC                                                         LEP00230
      COMMON/SHOCKC/XST(32,32),YST(32,32),ZST(32,32),ZET(32,32),        LEP00240
     1  QS(32,32),SHKWT                                                 LEP00250
*COMDECK VARS1                                                          LEP00260
      COMMON/VARS/Q(32,16,32),Q6(32,32),X(32),XX(32,4),YY(32,4)         LEP00270
     1,ZZ(32,4)                                                         LEP00280
*COMDECK VARS2                                                          LEP00290
      DIMENSION TURMU(32,16,32),Y(32,16,32),Z(32,16,32),S(32,16,32),    LEP00300
     1XXI(32,16,32),YXI(32,16,32),ZXI(32,16,32),DXIDX(32,16,32),        LEP00310
     2DXIDY(32,16,32),DXIDZ(32,16,32)                                   LEP00320
      EQUIVALENCE (Q,TURMU,Y,Z,S,XXI,YXI,ZXI,DXIDX,DXIDY,DXIDZ)         LEP00330
C                                                                       LEP00340
C     THE Q ARRAY IS USED AS FOLLOWS, WHERE JK IS EITHER J OR K:        LEP00350
C                                                                       LEP00360
C           Q(L, 1,JK)   Q(L, 1,JK)                    RHO              LEP00370
C           Q(L, 2,JK)   Q(L, 2,JK)                    RHO*U            LEP00380
C           Q(L, 3,JK)   Q(L, 3,JK)                    RHO*V            LEP00390
C           Q(L, 4,JK)   Q(L, 4,JK)                    RHO*W            LEP00400
C           Q(L, 5,JK)   Q(L, 5,JK)                    E                LEP00410
C           Q(L, 6,JK)TURMU(L, 6,JK)                   TURMU            LEP00420
C           Q(L, 7,JK)   Y(L, 7,JK)                    Y                LEP00430
C           Q(L, 8,JK)   Z(L, 8,JK)                    Z                LEP00440
C           Q(L, 9,JK)   S(L, 9,JK)                    S1               LEP00450
C           Q(L,10,JK)   S(L,10,JK)                    S2               LEP00460
C           Q(L,11,JK)   S(L,11,JK)                    S3               LEP00470
C           Q(L,12,JK)   S(L,12,JK)                    S4               LEP00480
C           Q(L,13,JK)   S(L,13,JK)                    S5               LEP00490
C           Q(L,14,JK) XXI(L,14,JK) OR DXIDX(L,14,JK)  DXDXI OR DXIDX   LEP00500
C           Q(L,15,JK) YXI(L,15,JK) OR DXIDY(L,15,JK)  DYDXI OR DXIDY   LEP00510
C           Q(L,16,JK) ZXI(L,16,JK) OR DXIDZ(L,16,JK)  DZDXI OF DXIDZ   LEP00520
C                                                                       LEP00530
C     THE JACOBIAN IS STORED IN Q(L,14,J) FOR CONSTANT K                LEP00540
C       AND IN Q(L,15,K) FOR CONSTANT J.                                LEP00550
C       WITHIN SWEEPS IT IS REFERENCED BY Q6(L,JK).                     LEP00560
C                                                                       LEP00570
*COMDECK VISC                                                           LEP00580
      COMMON/VISC/S0(32),S1(32),S2(32),S3(32),S4(32),S5(32),S6(32),U(32)LEP00590
     1  ,V(32),W(32),E(32),RR(32),DEU(32,5,5)                           LEP00600
*COMDECK VISCO                                                          LEP00610
      COMMON/VISCO/RMUEXP,ISUTH,TSUTH                                   LEP00620
*DECK NOZL3D                                                            LEP00630
      PROGRAM NOZL3D(INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT,TAPE2,TAPE4, LEP00640
     1 TAPE3       )                                                    LEP00650
*CALL BASE                                                              LEP00660
C                                                                       LEP00670
C     3-D IMPLICIT NAVIER-STOKES SOLVER FOR FULL NOZZLE GEOMETRY        LEP00680
C                                                                       LEP00690
      CALL INITIA                                                       LEP00700
      CALL GLOINT                                                       LEP00710
      IDTSW=0
      DO 100 NSTEP=1,NMAX                                               LEP00720
      NC=NSTEP+NC1                                                      LEP00730
      CALL STEP(DQ0QMX,IDTSW)                                           LEP00740
      CALL GLOINT                                                       LEP00750
      CALL NEWDT(DQ0QMX,IDTSW)                                          LEP00760
      IF(MOD(NSTEP,NROUT).NE.0 .OR. NSTEP.EQ.NMAX) GO TO 100            LEP00770
      CALL OUTALL(2)                                                    LEP00780
  100 CONTINUE                                                          LEP00790
      CALL OUTALL(-1)                                                   LEP00800
      STOP                                                              LEP00810
      END                                                               LEP00820
*DECK INITIA                                                            LEP00830
      SUBROUTINE INITIA                                                 LEP00840
*CALL BASE                                                              LEP00850
*CALL VARS1                                                             LEP00860
*CALL SHOCKC                                                            LEP00870
*CALL BTRID                                                             LEP00880
*CALL VISCO                                                             LEP00890
*CALL GLOB                                                              LEP00900
C     COMMON FREESP CONTAINS FREESTREAM PRESSURE                        LEP00910
      COMMON/FREESP/FSP,FSRHO                                           LEP00920
      COMMON/AXISYM/LAXIS                                               LEP00930
      COMMON/FILTR/INFLT                                                LEP00940
*CALL VARS2                                                             LEP00950
      DIMENSION DINTGL(1)                                               LEP00960
      DIMENSION IDPARS(4)                                               LEP00970
C     NOL MUST EQUAL THE FIRST DIMENSION OF Q (MULTIPLE OF 4 FOR CDC)   LEP00980
      NOL=32                                                            LEP00990
      IDPARS(1)=0                                                       LEP01000
      IDPARS(2)=0                                                       LEP01010
      IDPARS(3)=0                                                       LEP01020
      IDPARS(4)=0                                                       LEP01030
      CALL DMHAST(3,0,0)                                                LEP01040
      CALL DMDAST(13,0,IDPARS)                                          LEP01050
      PI = 4.*ATAN(1.)                                                  LEP01060
      NC1=0                                                             LEP01070
      TAU=0.0                                                           LEP01080
      NRES=1                                                            LEP01090
      NK=0                                                              LEP01100
C                                                                       LEP01110
C  READ DATA                                                            LEP01120
C                                                                       LEP01130
      READ (5,10)NMAX,JMAX,KMAX,LMAX,LAMIN,INVISC,J1BC,JMAXBC,KPLANE,K1BLEP01140
     1C,JK1WL,JK1WU,KW,JKW,KMAXBC                                       LEP01150
      READ (5,10)L1BC,JL1WL,JL1WU,LW,JLW,LMAXBC,NRST,IWRIT,NGRI,NP,KVIS LEP01160
     1,LVIS,KLVIS,INFLT,ISUTH,NROUT                                     LEP01170
      READ (5,15)DT,FSMACH,RMACH,RE,PR,RTDEGK,FSP,FST                   LEP01180
      READ (5,15)GAMMA,RMUEXP,TW,CNBR,DTFAC,RM,SMU,OMEGA                LEP01190
      READ (5,15) DTMAX                                                 LEP01200
   10 FORMAT(16I5)                                                      LEP01210
   15 FORMAT(8F10.0)                                                    LEP01220
      WRITE (6,20)NMAX,JMAX,KMAX,LMAX,LAMIN,INVISC,J1BC,JMAXBC,KPLANE,K1LEP01230
     1BC,JK1WL,JK1WU,KW,JKW,KMAXBC                                      LEP01240
      WRITE (6,25)L1BC,JL1WL,JL1WU,LW,JLW,LMAXBC,NRST,IWRIT,NGRI,NP,KVISLEP01250
     1,LVIS,KLVIS,INFLT,ISUTH,NROUT                                     LEP01260
      WRITE (6,30)DT,FSMACH,RMACH,RE,PR,RTDEGK,FSP,FST                  LEP01270
      WRITE (6,35)GAMMA,RMUEXP,TW,CNBR,DTFAC,RM,SMU,OMEGA               LEP01280
      WRITE(6,37) DTMAX                                                 LEP01290
   20 FORMAT(122H1    NMAX    JMAX    KMAX    LMAX    LAMIN  INVISC   J1LEP01300
     1BC   JMAXBC  KPLANE   K1BC    JK1WL   JK1WU    KW      JKW   KMAXBLEP01310
     1C     /16I8)                                                      LEP01320
   25 FORMAT(//132H     L1BC    JL1WL   JL1WU    LW      JLW   LMAXBC   LEP01330
     1 NRST   IWRIT   NGRI     NP      KVIS    LVIS   KLVIS   INFLT   ISLEP01340
     2UTH    NROUT      /16I8)                                          LEP01350
   30 FORMAT(//7X,2HDT,10X,6HFSMACH,10X,5HRMACH                         LEP01360
     1,12X,2HRE,13X,2HPR,11X,6HRTDEGK,10X,3HFSP,13X,3HFST,/1P8E15.7)    LEP01370
   35 FORMAT(//5X,5HGAMMA,10X,6HRMUEXP,11X,2HTW,12X,4HCNBR,10X,5HDTFAC, LEP01380
     1,13X,2HRM,12X,3HSMU,11X,5HOMEGA/1P8E15.7)                         LEP01390
   37 FORMAT(//5X,5HDTMAX/1PE15.7///)                                   LEP01400
C     RMACH IS REFERENCE MACH NUMBER                                    LEP01410
C     RE IS REYNOLD'S NUMBER AT REFERENCE CONDITIONS                    LEP01420
C      RTDEGK IS REFERENCE TEMPERATURE IN DEGREES KELVIN                LEP01430
C        (USED ONLY IN COMPUTING THE SUTHERLAND VISCOSITY)              LEP01440
C     FSMACH IS FREESTREAM MACH NUMBER                                  LEP01450
C       FSP IS DIMENSIONLESS FREESTREAM PRESSURE                        LEP01460
C       (NORMALIZED BY REFERENCE PRESSURE)                              LEP01470
C     FST IS DIMENSIONLESS FREESTREAM TEMPERATURE                       LEP01480
C        (NORMALIZED BY REFERENCE TEMPERATURE)                          LEP01490
C     INVISC=1 FOR INVISCID FLOW, 0 FOR VISCOUS FLOW                    LEP01500
C        (0 IS MANDATORY)                                               LEP01510
C     LAMIN=1 FOR LAMINAR FLOW, 0 FOR TURBULENT FLOW                    LEP01520
C                                                                       LEP01530
C     SET BOUNDARY CONDITION OPTIONS KPLANE=1 FOR PLANAR SYMMETRY       LEP01540
C     LMAXBC DEFINES BDY CONDITIONS AT THE SURFACE L=LMAX.  THE BC ARE HLEP01550
C     FIXED AT THEIR INITIAL VALUES FOR LMAXBC=0.                       LEP01560
C     LMAXBC=1 SELECTS IMPLICIT VISCOUS WALL BC                         LEP01570
C     LMAXBC=2 SELECTS IMPLICIT OUTFLOW BC WITH ENFORCED FREESTREAM     LEP01580
C              PRESSURE,FREESTREAM DENSITY                              LEP01590
C     LMAXBC=3 SELECTS REFLECTIVE SYMMETRY BC SUCH THAT LMAX IS A       LEP01600
C              SYMMETRY PLANE Z=CONSTANT AND THE                        LEP01610
C              W-VELOCITY COMPONENT IS ZERO IN THAT SYMMETRY PLANE.     LEP01620
C     LMAXBC=4 SELECTS REFLECTIVE SYMMETRY BC SUCH THAT LMAX IS A       LEP01630
C              SYMMETRY PLANE Y=CONSTANT AND THE V                      LEP01640
C              VELOCITY COMPONENT IS ZERO IN THAT SYMMETRY PLANE.       LEP01650
C     LMAXBC=5 SELECTS IMPLICIT OUTFLOW BC IN WHICH ALL VISCOUS STRESSESLEP01660
C              AND HEAT FLUXEX VANISH AT L=LMAX.                        LEP01670
C   NOTE LMAXBC = 0 CAN BE USED TO EMPLOY TIME-LAGGED BDRY CONDITIONS   LEP01680
C   AT LMAX, WHICH CAN BE CODED INTO SUBR. BC.  SIMILARLY TIME-LAGGED BCLEP01690
C     AT THE OTHER BDYS L=1,K=1,K=KMAX CAN BE CONSTRUCETD WHEN L1BC,K1BCLEP01700
C     OR KMAXBC ARE ZERO.                                               LEP01710
C                                                                       LEP01720
C     L1BC DEFINES THE BC AT THE SURFACE L=1                            LEP01730
C     L1BC=0 MEANS THE BC ARE HELD FIXED AT THEIR INITIAL VALUES.       LEP01740
C     L1BC=1 MEANS IMPLICIT VISCOUS WALL BC ARE APPLIED IN THE WALL     LEP01750
C            REGION(JL1WL.LE.J.LE.JL1WU) AND (1.LE.K.LE.KMAX).          LEP01760
C     THE REMAINDER OF THE SURFACE L=1 OUTSIDE THIS WALL REGION IS      LEP01770
C     ASSUMED TO COINCIDE WITH THE Z=0 PLANE, AND REFLECTIVE SUMMETRY BCLEP01780
C      ARE APPLIED SUCH THAT THE W-COMPONENT OF VELOCITY VANISHES IN    LEP01790
C     THE SYMMETRY PLANE.  WHEN KW.GT.0(SEE BELOW), THE DESCRBED WALL   LEP01800
C     REGION EXTENDS OUT ONLY TO K=KW RATHER THAN KMAX.                 LEP01810
C                                                                       LEP01820
C     KMAXBC DEFINES THE BC AT THE SURFACE K=KMAX.  THE OPTIONS ARE     LEP01830
C            IDENTICAL TO THOSE FOR LMAXBC                              LEP01840
C                                                                       LEP01850
C     K1BC DEFINES THE BC AT THE SURFACE K=1                            LEP01860
C     K1BC=0 MEANS THE BC ARE HELD FIXED AT THEIR INITIAL VALUES.       LEP01870
C     K1BC=1 MEANS IMPLICIT VISCOUS WALL BC ARE APPLIED IN THE WALL     LEP01880
C            REGION(JK1WL.LE.J.LE.JK1WU) AND (1.LE.L.LE.LMAX).          LEP01890
C     THE REMAINDER OF THE SURFACE K=1 OUTSIDE THIS WALL REGION IS      LEP01900
C     ASSUMED TO COINCIDE WITH THE Y=0 PLANE, AND REFLECTIVE SUMMETRY BCLEP01910
C      ARE APPLIED SUCH THAT THE V-COMPONENT OF VELOCITY VANISHES IN    LEP01920
C     THE SYMMETRY PLANE.  WHEN LW.GT.0(SEE BELOW), THE DESCRBED WALL   LEP01930
C     REGION EXTENDS OUT ONLY TO L=LW RATHER THAN LMAX.                 LEP01940
C                                                                       LEP01950
C     TW=0.0 SELECTS IMPLICIT ADIABATIC WALL BC FOR THE ENERGY EQUATION.LEP01960
C        A NON-ZERO INPUT VALUE OF TW IMPOSES A BOUNDARY CONDITION ON   LEP01970
C        DIMENSIONLESS ABSOLUTE WALL TEMPERATURE EQUAL TO TW.           LEP01980
      ITW=0                                                             LEP01990
      IF(TW.GT.0.0) ITW=1                                               LEP02000
C                                                                       LEP02010
C   SET OPTIONS FOR INFLOW (J=1) AND OUTFLOW(J=JMAX) BOUNDARIES         LEP02020
C   JMAXBC=2 FOR SUBSONIC OUTFLOW WITH FREESTREAM PRESSURE IMPOSED      LEP02030
C   JMAXBC.LT.2 FOR COMPUTED OUTFLOW B.C.                               LEP02040
C   J1BC=0 FOR FIXED (LAGGED) B.C. AT J=1.  J1BC.NE.0 USES INITIAL      LEP02050
C   VALUES OF TOTAL PRESSURE, TOTAL ENTHALPY, AND VELOCITY VECTOR       LEP02060
C   DIRECTION COSINES, TOGETHER WITH A CLOSING EQUATION OBTAINED EITHER LEP02070
C   FROM MOC THEORY(J1BC.LT.0) OR FROM THE CONTINUITY, U-MOMENTUM,OR    LEP02080
C   ENERGY EQUATION(J1BC.GT.0). SEE COMMENTS IN SUBR. BCJMAT            LEP02090
C                                                                       LEP02100
C   KVIS = 1(0) SPECIFIES THAT THE VISCOUS TERMS FOR THE ETA(K)         LEP02110
C   DIRECTION ARE TO BE INCLUDED IN (OMITTED FROM) THE COMPUTATION.     LEP02120
C   LVIS = 1(0) SIMILARLY CONTROLS THE COMPUTATION OF THE VISCOUS       LEP02130
C   TERMS FOR THE ZETA(L) COORDINATE DIRECTION                          LEP02140
C   KLVIS = 1(0) SIMILARLY CONTROLS THE COMPUTATION OF THE VISCOUS      LEP02150
C   CROSS DERIVATIVE TERMS FOR THE ETA AND ZETA COORDINATE DIRECTIONS.  LEP02160
C                                                                       LEP02170
C   SET NORMAL MASS INJECTION RATE WMDOT,NORMALIZED BY (FREESTREAM      LEP02180
C   DENSITY)*(FREESTREAM SOUND SPEED)                                   LEP02190
      WMDOT =0.0                                                        LEP02200
C   SET FINITE VOL/FINITE-DIFF WEIGHT FACTOR, WTFAC=0.75(1.0) FOR       LEP02210
C   FINITE-VOL (FINITE-DIFF) WEIGHTING OF DELTAQ AT BDY POINTS.         LEP02220
C     WTFAC=0.75 IS MANDATORY                                           LEP02230
C                                                                       LEP02240
      INXBC=1                                                           LEP02250
      WTFAC=0.75                                                        LEP02260
      NPLOT=0                                                           LEP02270
      IPLOT1=0                                                          LEP02280
      IPLOT2=0                                                          LEP02290
      CNBR=0.0                                                          LEP02300
      IF(KPLANE.EQ.1) KMAX=1                                            LEP02310
      NLROW=16*NOL                                                      LEP02320
      NKLP=KMAX*NLROW                                                   LEP02330
      NLSKIP=NKLP-NLROW                                                 LEP02340
      CF = 1.05                                                         LEP02350
      NC=NC1                                                            LEP02360
      ITMAX=NC1+NMAX                                                    LEP02370
      IGNCAL=2                                                          LEP02380
      SM0=0.5*SMU/(8.0*(3.0-FLOAT(KPLANE)))                             LEP02390
      JB=2                                                              LEP02400
      IF(J1BC.NE.0) JB=1                                                LEP02410
      LL=2                                                              LEP02420
      IF(L1BC.GT.0) LL=1                                                LEP02430
      LU=LMAX-1                                                         LEP02440
      IF(LMAXBC.GT.0) LU=LMAX                                           LEP02450
      IF(KPLANE.EQ.1) KMAXBC=0                                          LEP02460
      IF(KPLANE.EQ.1) K1BC=0                                            LEP02470
      KAL=2                                                             LEP02480
      IF(K1BC.GT.0) KAL=1                                               LEP02490
      KU=KMAX-1                                                         LEP02500
      IF(KMAXBC.GT.0) KU=KMAX                                           LEP02510
      IF(KPLANE.EQ.1) KU=1                                              LEP02520
      IF(KPLANE.EQ.1) KAL=1                                             LEP02530
C  COMPUTE CONSTANTS                                                    LEP02540
      FSRHO=FSP/FST                                                     LEP02550
      ALP=0.                                                            LEP02560
      TSUTH=110.33/RTDEGK                                               LEP02570
      GAMI = GAMMA-1                                                    LEP02590
      GD = GAMMA*GAMI                                                   LEP02600
      HD = .5*DT                                                        LEP02610
      JM = JMAX-1                                                       LEP02620
      KM = KMAX-1                                                       LEP02630
      IF(KPLANE.EQ.1) KM=1                                              LEP02640
      KL2=2                                                             LEP02650
      IF(KPLANE.EQ.1) KL2=1                                             LEP02660
      LM = LMAX-1                                                       LEP02670
      DX1 = 1.                                                          LEP02680
      DY1 = 1.                                                          LEP02690
      DZ1 = 1.                                                          LEP02700
      HDX = HD/DX1                                                      LEP02710
      HDY = HD/DY1                                                      LEP02720
      HDZ = HD/DZ1                                                      LEP02730
      CS = COS(PI*ALP/180.)                                             LEP02740
      SS = SIN(PI*ALP/180.)                                             LEP02750
      CWFAC=(2./(GAMMA+1.))**(.5*(GAMMA+1.)/(GAMMA-1.))                 LEP02760
C...FILL ZETA COORDINATE ARRAY                                          LEP02770
C     DO 1  K = 1,KMAX                                                  LEP02780
C     CALL ETATB(ZET(1,K),CF,LMAX)                                      LEP02790
C   1 CONTINUE                                                          LEP02800
C                                                                       LEP02810
C                                                                       LEP02820
C     INITIALIZE SHOCK GRID POINT VELOCITIES                            LEP02830
      DO 40 J=1,JMAX                                                    LEP02840
      DO 40 K=1,KMAX                                                    LEP02850
      XST(J,K)=0.0                                                      LEP02860
      YST(J,K)=0.0                                                      LEP02870
      ZST(J,K)=0.0                                                      LEP02880
   40 CONTINUE                                                          LEP02890
C  LOAD FREE STREAM AT ANGLE OF ATTACK ALP WHERE ALP IS                 LEP02900
C  MEASURED FROM X AXIS IN X,Y PLANE                                    LEP02910
      READ(2) KMAXR,JMAXR,LMAXR,ITMAXR,LMAXBC,L1BC,FSMACH,GAMMA,RER,    LEP02920
     1                                          SMUR,DTR,ALP,CNBR,PRR   LEP02930
      WRITE (6,45)KMAXR,JMAXR,LMAXR,ITMAXR,LMAXBC,L1BC,FSMACH,GAMMA,RER,LEP02940
     1SMUR,DTR,ALP,CNBR,PRR
   45 FORMAT(5X,55HTHIS IS A RESTART FROM THE FOLLOWING INITIAL CONDITIOLEP02960
     1NS                          /76H  KMAXR,JMAXR,LMAXR,ITMAXR,LMAXBC,LEP02970
     1L1BC,FSMACH,GAMMA,RE,SMUR,DTR,ALP,CNBR,PRR   /6I10/8E15.8)        LEP02980
      CNBR=0.0                                                          LEP02990
      WRITE(3)KMAX,JMAX,LMAX,ITMAX,LMAXBC,L1BC,FSMACH,GAMMA,RE,SMU,DT,  LEP03000
     1                                                       ALP,CNBR,PRLEP03010
      WRITE(4)KMAX,JMAX,LMAX,ITMAX,LMAXBC,L1BC,FSMACH,GAMMA,RE,SMU,DT,  LEP03020
     1                                                       ALP,CNBR,PRLEP03030
C...RESTART                                                             LEP03040
   50 READ(2) NC1,TAU,DTR,NK                                            LEP03050
      IF (NC1.GT.NRST) GO TO 160                                        LEP03060
      IF (NC1.EQ.NRST) GO TO 60                                         LEP03070
      DO 55 J=1,JMAXR                                                   LEP03080
   55 READ(2) DUM                                                       LEP03090
      GO TO 50                                                          LEP03100
   60 DO 100 J=1,JMAX                                                   LEP03110
      DO 65 K=1,KMAX                                                    LEP03120
      DO 65 L=1,LMAX                                                    LEP03130
         Q(L,1,K) = 1.0                                                 LEP03140
         Q(L,2,K) = FSMACH*CS                                           LEP03150
         Q(L,3,K) = 0.0                                                 LEP03160
         Q(L,4,K) = FSMACH*SS                                           LEP03170
         Q(L,5,K) =1./GD+.5*FSMACH**2                                   LEP03180
   65    CONTINUE                                                       LEP03190
      READ(2) (((Q(L,N,K),L=1,LMAXR),N=1,8),K=1,KMAXR)                  LEP03200
      IF(NGRI.EQ.1) CALL GRID(J)                                        LEP03210
C     SAVE X                                                            LEP03220
      X(J)=Q(1,6,1)                                                     LEP03230
C     PUT DXIDX ON DISK FOR INITIAL JACOBIAN CALCULATION                LEP03240
      DO 70 L=1,LMAX                                                    LEP03250
      CALL XXM(L,J,1,KMAX)                                              LEP03260
      DO 70 K=1,KMAX                                                    LEP03270
      DXIDX(L,14,K)=XX(K,1)                                             LEP03280
   70 CONTINUE                                                          LEP03290
C     ZERO OUT TURMU                                                    LEP03300
      DO 95 L=1,LMAX                                                    LEP03310
      DO 95 K=1,KMAX                                                    LEP03320
   95 TURMU(L,6,K)=0.0                                                  LEP03330
      CALL LKPIO(J,1)                                                   LEP03340
  100 CONTINUE                                                          LEP03350
C     SWITCH TO IDENTIFY AXIAL SYMMETRY                                 LEP03360
      LAXIS=0                                                           LEP03370
      IF(KPLANE.EQ.0.AND. ABS(Y(1,7,1)-Y(1,7,KMAX)).LT.1.E-6) LAXIS=1   LEP03380
C     FIND NOZZLE THROAT INDEX J=JTT                                    LEP03390
      JTT=1                                                             LEP03400
      DO 102 J=1,JMAX                                                   LEP03410
      IF(X(J).NE.0.) GO TO 102                                          LEP03420
      JTT=J                                                             LEP03430
      GO TO 103                                                         LEP03440
  102 CONTINUE                                                          LEP03450
  103 CONTINUE                                                          LEP03460
C     REDEFINE FSMACH AS DIMENSIONLESS FREESTREAM VELOCITY              LEP03470
C     (NORMALIZED BY REFERENCE SOUND SPEED)                             LEP03480
      FSMACH=FSMACH*SQRT(FST)                                           LEP03490
      RE = RE/RMACH                                                     LEP03500
C     I/O LJ-PLANES TO PUT Q6,YXI,ZXI ON DISC FOR CALC. Q6 IN JACOB     LEP03510
      DO 115 K=1,KMAX                                                   LEP03520
      CALL LJPIO(K,2)                                                   LEP03530
      DO 110 L=1,LMAX                                                   LEP03540
      DO 105 J=1,JMAX                                                   LEP03550
      CALL DJMET(J,L,XX(J,1),YXI(L,15,J),ZXI(L,16,J))                   LEP03560
      Q(L,14,J)=XX(J,1)*DXIDX(L,14,J)                                   LEP03570
  105 CONTINUE                                                          LEP03580
  110 CONTINUE                                                          LEP03590
      CALL LJPIO(K,1)                                                   LEP03600
  115 CONTINUE                                                          LEP03610
C                                                                       LEP03620
      CALL OUTALL(NC1)                                                  LEP03630
C                                                                       LEP03640
      DO 155 J=1,JMAX                                                   LEP03650
      CALL LKPIO(J,2)                                                   LEP03660
      DO 120 L=1,LMAX                                                   LEP03670
      DO 120 K=1,KMAX                                                   LEP03680
      Q6(L,K)=Q(L,14,K)                                                 LEP03690
      CALL DJMET2(J,L,XXI(L,14,K))                                      LEP03700
  120 CONTINUE                                                          LEP03710
      CALL JACOB(J)                                                     LEP03720
      IF(J.NE.JMAX) GO TO 124
C
C      ADJUST OUTFLOW PLANE VARIABLES TO SATISFY IMPOSED PRESSURE
C      BOUNDARY CONDITION P=FSP WHEN JMAXBC=2
C
      IF(JMAXBC.NE.2) GO TO 124
      DO 122 L=1,LMAX
      DO 122 K=1,KMAX
      RV=Q(L,2,K)**2+Q(L,3,K)**2+Q(L,4,K)**2
      POLD=GD*(Q(L,5,K)-RV/(2.*Q(L,1,K)))
      PNEW=FSP/POLD
      Q(L,1,K)=PNEW*Q(L,1,K)
      Q(L,5,K)=FSP/GD+RV/(2.*Q(L,1,K))
  122 CONTINUE
  124 CONTINUE
      CALL BC(J)                                                        LEP03730
      CALL GLOBL(J)                                                     LEP03740
      IF (J.NE.JTT) GO TO 90                                            LEP03750
C     COMPUTE NOZZLE THROAT AREA                                        LEP03760
      KT=KMAX                                                           LEP03770
      IF(KW.GT.0) KT=KW                                                 LEP03780
      LT=LMAX                                                           LEP03790
      IF(LW.GT.0) LT=LW                                                 LEP03800
      DO 80 L=1,LT                                                      LEP03810
      CALL XXM(L,J,1,KT)                                                LEP03820
      DO 75 K=1,KT                                                      LEP03830
      DA=SQRT(XX(K,1)*XX(K,1)+XX(K,2)*XX(K,2)+XX(K,3)*XX(K,3))          LEP03840
   75 A(K,1,1)=DA                                                       LEP03850
      CALL QDRTR(B(L,1,1),A(1,1,1),DY1,1,KT)                            LEP03860
   80 CONTINUE                                                          LEP03870
      CALL QDRTR(AT,B(1,1,1),DZ1,1,LT)                                  LEP03880
      IF(AT.LT.1.E-6) AT=1.                                             LEP03890
      WRITE (6,85)JTT,AT                                                LEP03900
   85 FORMAT(2X,28HTHROAT LOCATION X=0. AT JTT=  I3/                    LEP03910
     1  2X,15HTHROAT AREA AT=  1PE12.5)                                 LEP03920
   90 CONTINUE                                                          LEP03930
      IF (J.NE.JTT) GO TO 125                                           LEP03940
C     NOZZLE DISCHARGE COEFFICIENT CW                                   LEP03950
C     INTEGRATE MASS FLOW AT THROAT J=JT                                LEP03960
      NMX=1                                                             LEP03970
      L1=1                                                              LEP03980
      L2=LMAX                                                           LEP03990
      IF(LW.GT.0) L2=LW                                                 LEP04000
      K1=1                                                              LEP04010
      K2=KMAX                                                           LEP04020
      IF(KW.GT.0) K2=KW                                                 LEP04030
      CALL GDINTF(J,K1,K2,L1,L2,NMX,DINTGL)                             LEP04040
      CW=DINTGL(1)/(CWFAC*AT)                                           LEP04050
  125 CONTINUE                                                          LEP04060
      CALL PRECAL(J)                                                    LEP04070
      DO 130 L=1,LMAX                                                   LEP04080
      DO 130 K=1,KMAX                                                   LEP04090
      Q(L,15,K)=Q6(L,K)                                                 LEP04100
  130 CONTINUE                                                          LEP04110
C                                                                       LEP04120
C   COMPUTE HTOT AND PTOT (REFERENCED TO HREF AND PREF, RESP.), AND     LEP04130
C   VELOCITY VECTOR DIRECTION COSINES VOU=V/U, WOU=W/U AT INFLOW        LEP04140
C   BOUNDARY J=1.                                                       LEP04150
C                                                                       LEP04160
      IF (J.GT.1) GO TO 150                                             LEP04170
      IF (J1BC.EQ.0.AND.INXBC.EQ.0) GO TO 150                           LEP04180
      DO 140 K=1,KMAX                                                   LEP04190
      DO 140 L=1,LMAX                                                   LEP04200
      RR=1.0/Q(L,1,K)                                                   LEP04210
      XKE=0.5*(Q(L,2,K)**2 + Q(L,3,K)**2 + Q(L,4,K)**2)*RR**2           LEP04220
      ER=Q(L,5,K)*RR                                                    LEP04230
      HTOT(L,K)=GAMI*(GAMMA*ER-GAMI*XKE)                                LEP04240
      PTOT(L,K)=HTOT(L,K)*Q(L,1,K)*(GAMMA*GAMI*(ER-XKE)/                LEP04250
     1                                           HTOT(L,K))**(-1.0/GAMI)LEP04260
      IF (Q(L,2,K).NE.0.0) GO TO 135                                    LEP04270
      VOU(L,K)=1.0/SQRT(RE*FSMACH)                                      LEP04280
      WOU(L,K)=1.0/SQRT(RE*FSMACH)                                      LEP04290
      VOU(L,K)=0.                                                       LEP04300
      WOU(L,K)=0.                                                       LEP04310
      GO TO 140                                                         LEP04320
  135 VOU(L,K)=Q(L,3,K)/Q(L,2,K)                                        LEP04330
      WOU(L,K)=Q(L,4,K)/Q(L,2,K)                                        LEP04340
  140 CONTINUE                                                          LEP04350
      WRITE (6,145)((L,VOU(L,1),WOU(L,1),HTOT(L,1),PTOT(L,1)),L=1,LMAX) LEP04360
  145 FORMAT(5X,3HK=1/6X,1HL,8X,3HVOU,12X,3HWOU,11X,4HHTOT,             LEP04370
     1  10X,4HPTOT/(5X,I2,1P4E15.7))                                    LEP04380
  150 CONTINUE                                                          LEP04390
      CALL LKPIO(J,1)                                                   LEP04400
  155 CONTINUE                                                          LEP04410
      RETURN                                                            LEP04420
  160 WRITE (6,165)NC1,NRST                                             LEP04430
  165 FORMAT(30H  ***ERROR - INPUT VALUE NRST= I5,60H DOES NOT MATCH ANYLEP04440
     1 RESTART CYCLE NUMBER.  LAST CYCLE READ =   I5)                   LEP04450
      STOP                                                              LEP04460
      END                                                               LEP04470
*DECK AMATRX                                                            LEP04480
      SUBROUTINE AMATRX(A,JK,L,R1,R2,R3,R4)                             LEP04490
*CALL BASE                                                              LEP04500
*CALL VARS1                                                             LEP04510
*CALL VARS2                                                             LEP04520
      DIMENSION A(5,5)                                                  LEP04530
      GAM2 = 2.-GAMMA                                                   LEP04540
      RR = 1./Q(L,1,JK)                                                 LEP04550
      U = Q(L,2,JK)*RR                                                  LEP04560
      V = Q(L,3,JK)*RR                                                  LEP04570
      W = Q(L,4,JK)*RR                                                  LEP04580
      UU = U*R1+V*R2+W*R3                                               LEP04590
      UT = U**2+V**2+W**2                                               LEP04600
      C1 = GAMI*UT*.5                                                   LEP04610
      C2 = Q(L,5,JK)*RR*GAMMA                                           LEP04620
      A(1,1) = R4                                                       LEP04630
      A(1,2) = R1                                                       LEP04640
      A(1,3) = R2                                                       LEP04650
      A(1,4) = R3                                                       LEP04660
      A(1,5) = 0.                                                       LEP04670
      A(2,1) = R1*C1-U*UU                                               LEP04680
      A(2,2) = R4+UU+R1*GAM2*U                                          LEP04690
      A(2,3) = -R1*GAMI*V+R2*U                                          LEP04700
      A(2,4) = -R1*GAMI*W+R3*U                                          LEP04710
      A(2,5) = R1*GAMI                                                  LEP04720
      A(3,1) = R2*C1-V*UU                                               LEP04730
      A(3,2) = R1*V-R2*GAMI*U                                           LEP04740
      A(3,3) = R4+UU+R2*GAM2*V                                          LEP04750
      A(3,4) = -R2*GAMI*W+R3*V                                          LEP04760
      A(3,5) = R2*GAMI                                                  LEP04770
      A(4,1) = R3*C1-W*UU                                               LEP04780
      A(4,2) = R1*W-R3*GAMI*U                                           LEP04790
      A(4,3) = R2*W-R3*GAMI*V                                           LEP04800
      A(4,4) = R4+UU+R3*GAM2*W                                          LEP04810
      A(4,5) = R3*GAMI                                                  LEP04820
      A(5,1) = (-C2+2.*C1)*UU                                           LEP04830
      A(5,2) = R1*(C2-C1)-GAMI*U*UU                                     LEP04840
      A(5,3) = R2*(C2-C1)-GAMI*V*UU                                     LEP04850
      A(5,4) = R3*(C2-C1)-GAMI*W*UU                                     LEP04860
      A(5,5) = R4+GAMMA*UU                                              LEP04870
      RETURN                                                            LEP04880
      END                                                               LEP04890
*DECK BC
      SUBROUTINE BC(JJ)
*CALL BASE
*CALL VARS1
*CALL SHOCKC
*CALL RHSBCC
      COMMON/AXISYM/LAXIS
*CALL VARS2
      P(IL,IK)=GD*(Q(IL,5,IK)-.5*(Q(IL,2,IK)**2+Q(IL,3,IK)**2
     1   +Q(IL,4,IK)**2)/Q(IL,1,IK))
      EAVG(ILL,IKL,ILB,IKB)=.5*(Q(ILL,5,IKL)+Q(ILB,5,IKB))
      EORAVG(ILL,IKL,ILB,IKB)=.5*(Q(ILL,5,IKL)/Q(ILL,1,IKL)+Q(ILB,5,IKB)
     1  /Q(ILB,1,IKB))
      J=JJ
C     ELIMINATE ROUNDOFF ERROR IN TRANSVERSE VELOCITY V FOR PLANE FLOW
C     IN THE XZ PLANE (PLANE=1) AND ENFORCE PLANAR SYMMETRY
      IF(KMAX.EQ.1) GO TO 95
      IF(KPLANE.EQ.0) GO TO 95
      DO 90 L=1,LMAX
      DO 90 K=2,KMAX
      DO 85 N=1,5
   85 Q(L,N,K)=Q(L,N,1)
      Q(L,3,K)=0.
   90 CONTINUE
   95 CONTINUE
C     LAGGED B.C. FOR INTERNAL CORNERS AND SINGULARITIES
C     INTERNAL CORNER AT KMAX,LMAX
      IF(KPLANE.EQ.1) GO TO 100
      IF(KMAXBC.NE.1 .OR. LMAXBC.NE.1) GO TO 100
      IF(J.LT.JB) GO TO 1000
      LLL=LMAX
      KLL=KMAX-1
      LLB=LMAX-1
      KLB=KMAX
      L=LMAX
      K=KMAX
      Q(L,5,K)=EAVG(LLL,KLL,LLB,KLB)
      Q(L,1,K)=Q(L,5,K)/EORAVG(LLL,KLL,LLB,KLB)
  100 CONTINUE
      IF(NC.EQ.0) GO TO 1000
C     ELIMINATE ANY OUTFLOW OF COMPUTED INFLOW PLANE J=1
C     IF(J.NE.1) GO TO 600
C     IF(J1BC.NE.1) GO TO 600
C     DO 500 L=LL,LU
C     DO 500 K=KAL,KU
C     IF(Q(L,2,K).GE.0) GO TO 500
C     Q(L,2,K)=0.
C     Q(L,3,K)=0.
C     Q(L,4,K)=0.
C     Q(L,5,K)=PTOT(L,K)/GD
C     Q(L,1,K)=PTOT(L,K)/HTOT(L,K)
C 500 CONTINUE
  600 CONTINUE
C     B.C. AT SINGULAR AXIS L=1 FOR AXISYMMETRIC FLOW
      IF(ABS(Y(1,7,KMAX)-Y(1,7,1)).GT.1.E-6 .OR. KPLANE.EQ.1) GO TO 1000
C     SET V=W=0 AND EXTRAPOLATE U,RHO,T QUADRATICALLY WITH ZERO NORMAL
C     GRADIENT AT AXIS
      IF(J.LT.JB) GO TO 1000
      RHO=0.
      U=0.
      TEM=0.
      DO 900 K=1,KMAX
      RHO1=Q(2,1,K)
      RHO2=Q(3,1,K)
      U1=Q(2,2,K)/RHO1
      U2=Q(3,2,K)/RHO2
      V1=Q(2,3,K)/RHO1
      V2=Q(3,3,K)/RHO2
      W1=Q(2,4,K)/RHO1
      W2=Q(3,4,K)/RHO2
      T1=GD*(Q(2,5,K)/RHO1-.5*(U1**2+V1**2+W1**2))
      T2=GD*(Q(3,5,K)/RHO2-.5*(U2**2+V2**2+W2**2))
      RHO=RHO+4.*RHO1-RHO2
      U=U+4.*U1-U2
  900 TEM=TEM+4.*T1-T2
      U=U/(3.*KMAX)
      RHO=RHO/(3.*KMAX)
      TEM=TEM/(3.*KMAX)
      IF(J.NE.1) GO TO 920
      IF(J1BC.EQ.0) GO TO 920
      TEM=HTOT(1,1)*(RHO*HTOT(1,1)/PTOT(1,1))**GAMI
      U=SQRT(2.*(HTOT(1,1)-TEM)/GAMI)
  920 CONTINUE
      DO 940 K=1,KMAX
      Q(1,1,K)=RHO
      Q(1,2,K)=RHO*U
      Q(1,3,K)=0.
      Q(1,4,K)=0.
  940 Q(1,5,K)=RHO*(TEM/GD+.5*U**2)
C     ELIMINATE ROUNDOFF ERROR FOR AXISYMMETRIC FLOW
      PI2=2.*ATAN(1.)
      PIP=PI2/(KMAX-1.)
      DO 950 L=1,LMAX
      DO 945 K=2,KMAX
      THET=(K-1)*PIP
      Q(L,1,K)=Q(L,1,1)
      Q(L,2,K)=Q(L,2,1)
      Q(L,5,K)=Q(L,5,1)
      Q(L,3,K)=Q(L,4,1)*SIN(THET)
  945 Q(L,4,K)=Q(L,4,1)*COS(THET)
      Q(L,4,KMAX)=0.
  950 CONTINUE
 1000 CONTINUE
C     LAGGED B.C. FOR SINGULAR CORNERS AND EDGES
C     AXIAL INTERSECTION OF VERTICAL AND HORIZONTAL WALLS IN PLANES
C     L=1 AND K=1
      IF(JL1WU.LE.0 .OR. JK1WU.LE.0) GO TO 150
      J1= MAX0(JL1WL,JK1WL)
      J2=MIN0(JL1WU,JK1WU)
      IF(J.LT.J1.OR.J.GT.J2) GO TO 150
      LLL=1
      KLL=2
      LLB=2
      KLB=1
      Q(1,5,1)=EAVG(LLL,KLL,LLB,KLB)
      Q(1,1,1)=Q(1,5,1)/EORAVG(LLL,KLL,LLB,KLB)
C     CORNERS AND EDGES OF INTERMEDIATE WALLS
  150 IF(KW.LE.0 .AND. LW.LE.0) GO TO 185
      IF(KW.GT.0 .AND. LW.GT.0) GO TO 170
C     TRAILING EDGE OF LONE INTERNAL WALL THAT SPANS ENTIRE WIDTH OF
C     COMPUTATIONAL DOMAIN
      DO 165 IW=1,2
      CALL SW
      IF(LORKW.LE.0) GO TO 165
      IF(J.NE.JLKW) GO TO 165
      I1=0
      LORK=LORKW
      L1=-1
      K1=0
      IF(IW.EQ.2) L1=0
      IF(IW.EQ.2) K1=-1
  155 DO 160 K=KLORLL,KUORLU
      LLL=LORK
      KKK=K
      IF(IW.EQ.2) LLL=K
      IF(IW.EQ.2) KKK=LORK
      Q(LLL,1,KKK)=Q(LLL+L1,1,KKK+K1)
  160 Q(LLL,5,KKK)=P(LLL+L1,KKK+K1)/GD
      IF(I1.EQ.1) GO TO 165
      I1=1
      LORK=LORKW+1
      L1=-L1
      K1=-K1
      GO TO 155
  165 CONTINUE
      GO TO 255
C     CORNERS AND EDGES OF BOTH INTERMEDIATE WALLS
  170 CONTINUE
C     AXIAL INTERSECTIONS OF THE TWO WALLS
      J2=MIN0(JKW,JLW)
      IF(J.GT.J2) GO TO 185
C     INTERNAL CORNER
      K=KW
      L=LW
      I1=0
  175 IF(J.NE.1)  GO TO 177
      IF(NC.EQ.NRST) GO TO 185
      Q(L,5,K)=PTOT(L,K)/GD
      Q(L,1,K)=PTOT(L,K)/HTOT(L,K)
      IF(I1.EQ.1) GO TO 185
      GO TO 180
  177 LLL=L
      KLL=K-1
      LLB=L-1
      KLB=K
      Q(L,5,K)=EAVG(LLL,KLL,LLB,KLB)
      Q(L,1,K)=Q(L,5,K)/EORAVG(LLL,KLL,LLB,KLB)
      IF(I1.EQ.1) GO TO 185
C     EXTERNAL CORNER
  180 I1=1
      K=KW+1
      L=LW+1
      GO TO 175
  185 DO 250 IW=1,2
      CALL SW
C     INTERSECTION OF PLUG AT LORK=1 WITH SIDEPLATE AT KORL=KORLW OR KORLMX
      IF(JLK1WU.LE.0) GO TO 200
      IF(J.LT.JLK1WL.OR.J.GT.JLK1WU) GO TO 200
      LORK=1
      IF(KORLW.EQ.0) KORL=KORLMX
      IF(KORL.EQ.1) GO TO 200
      IF(KORLW.NE.0) KORL=KORLW
      IF(IW.EQ.2) GO TO 187
      L=LORK
      K=KORL
      LLL=L+1
      KLL=K
      LLB=L
      KLB=K-1
      GO TO 190
  187 L=KORL
      K=LORK
      LLL=L
      KLL=K+1
      LLB=L-1
      KLB=K
  190 Q(L,5,K)=EAVG(LLL,KLL,LLB,KLB)
      Q(L,1,K)=Q(L,5,K)/EORAVG(LLL,KLL,LLB,KLB)
C     TRAILING EDGES OF WALL AT J=JLKW
  200 IF(J.NE.JLKW) GO TO 215
      K2=KORLW-1
      LORK=LORKW
      I1=0
      L1=-1
      K1=0
      IF(IW.EQ.2) L1=0
      IF(IW.EQ.2) K1=-1
  205 DO 210 KORL=KLORLL,K2
      L=LORK
      K=KORL
      IF(IW.EQ.2) L=KORL
      IF(IW.EQ.2) K=LORK
      Q(L,1,K)=Q(L+L1,1,K+K1)
  210 Q(L,5,K)=P(L+L1,K+K1)/GD
      IF(I1.EQ.1) GO TO 215
      I1=1
      LORK=LORKW+1
      L1=-L1
      K1=-K1
      GO TO 205
  215 IF(JKLW-JLKW) 250,220,230
C     CORNER POINTS AT MUTUAL TRAILING EDGE OF THE TWO WALLS
  220 IF(J.NE.JKLW) GO TO 250
      LORK=LORKW
      KORL=KORLW
      I1=0
      L1=-1
      K1=-1
  225 K=KORL
      L=LORK
      IF(IW.EQ.2) K=LORK
      IF(IW.EQ.2) L=KORL
      Q(L,1,K)=Q(L+L1,1,K+K1)
      Q(L,5,K)=P(L+L1,K+K1)/GD
      IF(I1.EQ.1) GO TO 250
      I1=1
      LORK=LORK+1
      KORL=KORL+1
      L1=-L1
      K1=-K1
      GO TO 225
C     INNER CORNER AND UPPER EDGE OF PROTRUDING SIDEPLATE
C     PROTRUDING EDGE POINTS AT LORKW
  230 IF(J.NE.JLKW) GO TO 232
C      INNER CORNER
      LORK=LORKW
      KORL=KORLW
      L1=-1
      K1=0
      L=LORK
      K=KORL
      IF(IW.EQ.1) GO TO 231
      L1=0
      K1=-1
      K=LORK
      L=KORL
  231 Q(L,1,K)=Q(L+L1,1,K+K1)
      Q(L,5,K)=P(L+L1,K+K1)/GD
C      PROTRUDING EDGE POINTS AT LORKW
  232 IF(J.NE.JKLW) GO TO 235
      LORK=LORKW
      KORL=KORLW
      L1=-1
      K1=0
      I1=0
  233 L=LORK
      K=KORL
      IF(IW.EQ.1) GO TO 234
      L1=0
      K1=-1
      K=LORK
      L=KORL
  234 Q(L,1,K)=Q(L+L1,1,K+K1)
      Q(L,5,K)=P(L+L1,K+K1)/GD
      IF(I1.EQ.1)GO TO 235
      KORL=KORL+1
      I1=1
      GO TO 233
  235 CONTINUE
C
C    UPPER EDGES
C
      IF(J.LT.JLKW.OR.J.GT.JKLW) GO TO 250
      LORK=LORKW+1
      KORL=KORLW
      I1=0
  237 K=KORL
      L=LORK
      L1=1
      K1=0
      IF(IW.EQ.1) GO TO 240
      L=KORL
      K=LORK
      L1=0
      K1=1
  240 Q(L,1,K)=Q(L+L1,1,K+K1)
      Q(L,5,K)=P(L+L1,K+K1)/GD
      IF(I1.EQ.1) GO TO 250
      I1=1
      KORL=KORL+1
      GO TO 237
  250 CONTINUE
  255 CONTINUE
C     FILTER SOLUTION AT INFLOW BOUNDARY
      INFILT=0
      IF(RM.EQ.0.) RETURN
      IF(INFILT.EQ.0.OR.J1BC.NE.1) RETURN
      IF(NC.EQ.0) RETURN
      J=1
      L1=1
      IF(LAXIS.EQ.0.AND.L1BC.EQ.1.AND.JL1WL.EQ.1) L1=2
      L2=LM
      IF(LW.GT.0) L2=LW-1
      K1=1
      IF(KPLANE.EQ.0.AND.K1BC.EQ.1.AND.JK1WL.EQ.1) K1=2
      K2=KM
      IF(KW.GT.0) K2=KW-1
      IF(KPLANE.EQ.1) K2=1
C     FILTER DENSITY OVER L
      DO 350 K=K1,K2
      DO 320 L=L1,L2
      IF(L-1)315,305,315
  305 S(L,9,K)=.5*(Q(L,1,K)+Q(L+1,1,K))
      GO TO 320
  315 S(L,9,K)=.25*(Q(L-1,1,K)+Q(L+1,1,K)+2.*Q(L,1,K))
  320 CONTINUE
      DO 330 L=L1,L2
  330 Q(L,1,K)=S(L,9,K)
  350 CONTINUE
C     FILTER DENSITY OVER K
      DO 500 L=L1,L2
      IF(K1.EQ.K2) GO TO 400
      DO 380 K=K1,K2
      IF(K-1) 365,355,365
  355 S(L,9,K)=.5*(Q(L,1,K)+Q(L+1,1,K))
      GO TO 380
  365 S(L,9,K)=.25*(Q(L-1,1,K)+Q(L+1,1,K)+2.*Q(L,1,K))
  380 CONTINUE
      DO 390 K=K1,K2
  390 Q(L,1,K)=S(L,9,K)
C     RECOMPUTE MOMENTUM FLUXES AND ENERGY IN TERMS OF FILTERED DENSITY
C     AND OF KNOWN TOTAL PRESSURE, TOTAL TEMPERATURE, AND VELOCITY
C     VECTOR INCLINATION
  400 DO 450 K=K1,K2
      RGMI=(Q(L,1,K)*HTOT(L,K)/PTOT(L,K))**GAMI
      VSQ=2.*HTOT(L,K)*(1.-RGMI)/GAMI
      Q(L,2,K)=Q(L,1,K)*SQRT(VSQ/(1.+VOU(L,K)**2+WOU(L,K)**2))
      Q(L,3,K)=Q(L,2,K)*VOU(L,K)
      Q(L,4,K)=Q(L,2,K)*WOU(L,K)
  450 Q(L,5,K)=Q(L,1,K)*HTOT(L,K)*(GAMMA-GAMI*RGMI)/GD
  500 CONTINUE
      RETURN
      END
*DECK BCALJ                                                             LEP06260
      SUBROUTINE BCALJ(K,L)                                             LEP06270
*CALL BASE                                                              LEP06280
*CALL RHSBCC                                                            LEP06290
      COMMON/AXISYM/LAXIS                                               LEP06300
C     SET UP MATRICES FOR ALGEBRAIC BC AT UPPER & LOWER BDYS & INT WALLSLEP06310
      DO 1500 IW=1,2                                                    LEP06320
      CALL SW                                                           LEP06330
      KORL=K                                                            LEP06340
      LORK=L                                                            LEP06350
      IF(IW.EQ.1) GO TO 100                                             LEP06360
      KORL=L                                                            LEP06370
      LORK=K                                                            LEP06380
  100 IF(LORK.LT.LORKMX) GO TO 600                                      LEP06390
C     BC AT K=KMAX OR L=LMAX                                            LEP06400
      IF(LKMXBC.EQ.0.OR.LKMXBC.GE.3) GO TO 600                          LEP06410
      IF(LKMXBC-2) 400,200,200                                          LEP06420
  200 DO 300 J=JB,JMAX                                                  LEP06430
  300 CALL BCFMAT(J,K,L,1,J)                                            LEP06440
      GO TO 600                                                         LEP06450
  400 DO 500 J=JB,JMAX                                                  LEP06460
  500 CALL BCWMAT(J,K,L,1,J)                                            LEP06470
      IF(JMAXBC.EQ.2) CALL BCJMAT(JMAX,K,L,1)                           LEP06480
C     BC AT L=1 OR K=1                                                  LEP06490
  600 IF(LORK.GT.1) GO TO 1100                                          LEP06500
C     TEST FOR INTERMEDIATE WALL NORMAL TO LORK=1 SURFACE               LEP06510
      IF(KORLW) 700,700,1000                                            LEP06520
  700 JBCMIN=MAX0(JLK1WL,JB)                                            LEP06530
      JBCMAX=JLK1WU                                                     LEP06540
  800 IF(JBCMAX.LE.JBCMIN) GO TO 1100                                   LEP06550
      DO 900 J=JBCMIN,JBCMAX                                            LEP06560
  900 CALL BCWMAT(J,K,L,1,J)                                            LEP06570
      GO TO 1100                                                        LEP06580
 1000 IF(KORL.LT.KORLW) GO TO 700                                       LEP06590
 1100 CONTINUE                                                          LEP06600
C     BC AT INTERMEDIATE WALLS                                          LEP06610
      IF(LORKW.EQ.0) GO TO 1500                                         LEP06620
      IF(LORK.LT.LORKW.OR.LORK.GT.LORKW+1) GO TO 1500                   LEP06630
      IF(KORLW.GT.0.AND.KORL.GT.KORLW+1) GO TO 1500                     LEP06640
      JBCMIN=JB                                                         LEP06650
      JBCMAX=JLKW                                                       LEP06660
      IF(JBCMAX.LE.JBCMIN) GO TO 1500                                   LEP06670
      DO 1200 J=JBCMIN,JBCMAX                                           LEP06680
 1200 CALL BCWMAT(J,K,L,1,J)                                            LEP06690
 1500 CONTINUE                                                          LEP06700
C     SET UP MATRIX ELEMENTS FOR USE OF LAGGED B.C.                     LEP06710
C     SINGULAR AXIS L= FOR AXIAL SYMMETRY (LAXIS=1)                     LEP06720
      IF (L.NE.LAXIS) GO TO 80                                          LEP06730
      DO 75 J=1,JMAX                                                    LEP06740
   75 CALL ZERODQ(J)                                                    LEP06750
      GO TO 155                                                         LEP06760
C     INTERNAL CORNER AT KMAX,LMAX                                      LEP06770
   80 IF (KMAXBC.NE.1.OR.LMAXBC.NE.1) GO TO 90                          LEP06780
      IF (K*L.NE.KMAX*LMAX) GO TO 90                                    LEP06790
      DO 85 J=1,JMAX                                                    LEP06800
   85 CALL ZERODQ(J)                                                    LEP06810
      GO TO 155                                                         LEP06820
C     CORNER AT L=1, K=1                                                LEP06830
   90 IF (K*L.NE.1) GO TO 101                                           LEP06840
      IF (JK1WU*JL1WU.LE.0) GO TO 101                                   LEP06850
      J2=MIN0(JK1WU,JL1WU)                                              LEP06860
      J1=MAX0(1,JK1WL,JL1WL)                                            LEP06870
      IF (J2.LT.J1) GO TO 101                                           LEP06880
      DO 95 J=J1,J2                                                     LEP06890
   95 CALL ZERODQ(J)                                                    LEP06900
C     TRAILING EDGES AND CORNERS OF INTERMEDIATE WALLS                  LEP06910
      IF(KW.LE.0 .AND. LW.LE.0) GO TO 155                               LEP06920
  101 DO 135 IW=1,2                                                     LEP06930
      CALL SW                                                           LEP06940
      KORL=K                                                            LEP06950
      LORK=L                                                            LEP06960
      IF (IW.EQ.1) GO TO 105                                            LEP06970
      KORL=L                                                            LEP06980
      LORK=K                                                            LEP06990
  105 IF (KORLW.LE.0) GO TO 135                                         LEP07000
      IF (KORL.LT.KORLW.OR.KORL.GT.KORLW+1) GO TO 135                   LEP07010
C     TRAILING EDGE OF WALL KORL=KORLW                                  LEP07020
      IF (LORKW) 115,115,110                                            LEP07030
  110 IF (LORK.GT.LORKW) GO TO 125                                      LEP07040
  115 CALL ZERODQ(JKLW)                                                 LEP07050
C     CORNER OF INTERSECTION WITH PLUG AT LORK=1                        LEP07060
      IF (LORK.NE.1.OR.KORL.NE.KORLW) GO TO 125                         LEP07070
      J2=JLK1WU                                                         LEP07080
      J1=MAX0(JLK1WL,1)                                                 LEP07090
      IF (J2.LT.J1) GO TO 125                                           LEP07100
      DO 120 J=J1,J2                                                    LEP07110
  120 CALL ZERODQ(J)                                                    LEP07120
C     INNER EDGE OF PROTRUDING SIDEPLATE                                LEP07130
  125 IF(LORKW.EQ.0) GO TO 135                                          LEP07140
      IF (LORK.NE.LORKW+1.OR.KORL.NE.KORLW) GO TO 135                   LEP07150
      IF (JLKW.GE.JKLW) GO TO 135                                       LEP07160
      DO 130 J=JLKW,JKLW                                                LEP07170
  130 CALL ZERODQ(J)                                                    LEP07180
  135 CONTINUE                                                          LEP07190
C     CORNERS WHERE THE INTERMEDIATE WALLS INTERSECT                    LEP07200
      IF (KW*LW.LE.0) GO TO 155                                         LEP07210
      IF (L.NE.LW.OR.K.NE.KW) GO TO 145                                 LEP07220
      J2=MIN0(JKW,JLW)                                                  LEP07230
      DO 140 J=1,J2                                                     LEP07240
  140 CALL ZERODQ(J)                                                    LEP07250
      GO TO 155                                                         LEP07260
  145 IF (L.NE.LW+1.OR.K.NE.KW+1) GO TO 155
      J2=MAX0(JKW,JLW)                                                  LEP07280
      DO 150 J=1,J2                                                     LEP07290
  150 CALL ZERODQ(J)                                                    LEP07300
  155 CONTINUE                                                          LEP07310
C                                                                       LEP07320
C     PRESEVE INITIAL DATA AT INFLOW PLANE J=1 IN REGION OUTSIDE NOZZLE LEP07330
      IF(LW) 2100,2100,2300                                             LEP07340
 2100 IF(KW.LE.0) GO TO 3000                                            LEP07350
      IF(K.LE.KW) GO TO 3000                                            LEP07360
 2200 CALL ZERODQ(1)                                                    LEP07370
      GO TO 3000                                                        LEP07380
 2300 IF(KW) 2400,2400,2500                                             LEP07390
 2400 IF(L.LE.LW) GO TO 3000                                            LEP07400
      GO TO 2200                                                        LEP07410
 2500 IF(K.GT.KW .AND. L.GT.LW) CALL ZERODQ(1)                          LEP07420
 3000 CONTINUE                                                          LEP07430
C
C      LAGGED B.C. FOR NOZZLE LIP WALL POINTS AT J=JMAX WHEN JMAXBC=2
C     (OUTFLOW B.C. P=FSP IMPOSED)
C
      IF(JMAXBC .EQ. 2) GO TO 9999
      IF(ITW.EQ.1) GO TO 9999
      J=JMAX
C
C      HORIZONTAL WALLS AT L=1,LMAX
C
      IF(L.EQ.LMAX.AND.LMAXBC.EQ.1) CALL ZERODQ(J)
C
C      VERTICAL WALLS AT K=1,KMAX
C
      IF(KPLANE.EQ.1) GO TO 9999
      IF(K.EQ.KMAX.AND.KMAXBC.EQ.1) CALL ZERODQ(J)
 9999 RETURN
      END                                                               LEP07450
*DECK BCALKL                                                            LEP07460
      SUBROUTINE BCALKL(JJ,LORK,IWW)                                    LEP07470
*CALL BASE                                                              LEP07480
*CALL RHSBCC                                                            LEP07490
      COMMON/AXISYM/LAXIS                                               LEP07500
      ISW=IWW+1                                                         LEP07510
      IW=IWW                                                            LEP07520
      J=JJ                                                              LEP07530
      CALL SW                                                           LEP07540
C     SET UP MATRICES FOR ALGEBRAIC BC AT LOWER,UPPER BDYS AND INT WALLSLEP07550
      IF(LORK.LT.LORKMX) GO TO 230                                      LEP07560
C     BC AT LORK=LORKMX                                                 LEP07570
      IF(LKMXBC.LT.1.OR.LKMXBC.GT.2) GO TO 230                          LEP07580
      IF(LKMXBC-2) 220,210,210                                          LEP07590
C     FREESTREAM BC                                                     LEP07600
  210 DO 215 K=KLORLL,KUORLU                                            LEP07610
      KR=K                                                              LEP07620
      LR=LORK                                                           LEP07630
      IF(IW.EQ.1) GO TO 215                                             LEP07640
      KR=LORK                                                           LEP07650
      LR=K                                                              LEP07660
  215 CALL BCFMAT(J,KR,LR,ISW,KR)                                       LEP07670
      GO TO 230                                                         LEP07680
C     WALL BC                                                           LEP07690
  220 DO 225 K=KLORLL,KUORLU                                            LEP07700
      KR=K                                                              LEP07710
      LR=LORK                                                           LEP07720
      IF(IW.EQ.1) GO TO 223                                             LEP07730
      KR=LORK                                                           LEP07740
      LR=K                                                              LEP07750
  223 CALL BCWMAT(J,KR,LR,ISW,KR)                                       LEP07760
      IF(J.EQ.JMAX .AND. JMAXBC.EQ.2) CALL BCJMAT(J,KR,LR,ISW)          LEP07770
  225 CONTINUE                                                          LEP07780
C     BC AT INTERMEDIATE WALLS                                          LEP07790
  230 IF(KORLW.LE.0) GO TO 260                                          LEP07800
      IF(J.GT.JKLW) GO TO 260                                           LEP07810
      IF(LORKW.GT.0.AND.LORK.GT.LORKW+1) GO TO 280                      LEP07820
      KR=KORLW                                                          LEP07830
      LR=LORK                                                           LEP07840
      IF(IW.EQ.1) CALL BCWMAT(J,KR+1,LR,ISW,KR+1)
      IF(IW.EQ.1) GO TO 240                                             LEP07860
      KR=LORK                                                           LEP07870
      LR=KORLW                                                          LEP07880
      CALL BCWMAT(J,KR,LR+1,ISW,KR)                                     LEP07890
  240 CALL BCWMAT(J,KR,LR,ISW,KR)                                       LEP07900
  260 IF(LORKW.LE.0) GO TO 280                                          LEP07910
      IF(J.GT.JLKW) GO TO 280                                           LEP07920
      IF(LORK.LT.LORKW.OR.LORK.GT.LORKW+1) GO TO 280                    LEP07930
      KBCMAX=KORLMX                                                     LEP07940
      IF(KORLW.GT.0) KBCMAX=KORLW+1                                     LEP07950
      DO 270 K=KLORLL,KBCMAX                                            LEP07960
      KR=K                                                              LEP07970
      LR=LORK                                                           LEP07980
      IF(IW.EQ.1) GO TO 270                                             LEP07990
      KR=LORK                                                           LEP08000
      LR=K                                                              LEP08010
  270 CALL BCWMAT(J,KR,LR,ISW,KR)                                       LEP08020
C     BC AT LORK=1                                                      LEP08030
  280 IF(LORK.NE.1.OR.LK1BC.EQ.0) GO TO 287                             LEP08040
      KBCMAX=KORLMX                                                     LEP08050
      IF(KORLW.GT.0) KBCMAX=KORLW                                       LEP08060
      IF(J.LT.JLK1WL.OR.J.GT.JLK1WU) GO TO 290                          LEP08070
      DO 285 K=KLORLL,KBCMAX                                            LEP08080
      KR=K                                                              LEP08090
      LR=LORK                                                           LEP08100
      IF(IW.EQ.1) GO TO 283                                             LEP08110
      KR=LORK                                                           LEP08120
      LR=K                                                              LEP08130
  283 CALL BCWMAT(J,KR,LR,ISW,KR)
      IF(J.EQ.JMAX .AND. JMAXBC.EQ.2) CALL BCJMAT(J,KR,LR,ISW)          LEP08150
  285 CONTINUE                                                          LEP08160
C     BC AT KORL=1                                                      LEP08170
  287 IF(KL1BC.EQ.0) GO TO 320                                          LEP08180
C     TEST FOR INTERMEDIATE WALL                                        LEP08190
  290 IF(LORKW) 300,300,310                                             LEP08200
  300 IF(J.LT.JKL1WL.OR.J.GT.JKL1WU) GO TO 320                          LEP08210
      KR=1                                                              LEP08220
      LR=LORK                                                           LEP08230
      IF(IW.EQ.1) GO TO 305                                             LEP08240
      KR=LORK                                                           LEP08250
      LR=1                                                              LEP08260
  305 CALL BCWMAT(J,KR,LR,ISW,KR)                                       LEP08270
      IF(J.EQ.JMAX .AND. JMAXBC.EQ.2) CALL BCJMAT(J,KR,LR,ISW)          LEP08280
      GO TO 320                                                         LEP08290
  310 IF(LORK.LE.LORKW) GO TO 300                                       LEP08300
C     BC AT KORL=KORLMX                                                 LEP08310
  320 IF(KLMXBC.LT.1.OR.KLMXBC.GT.2) GO TO 105
      KR=KORLMX                                                         LEP08330
      LR=LORK                                                           LEP08340
      IF(IW.EQ.1) GO TO 335                                             LEP08350
      KR=LORK                                                           LEP08360
      LR=KORLMX                                                         LEP08370
  335 IF(KLMXBC-2) 340,330,330                                          LEP08380
C     FREESTREAM BC                                                     LEP08390
  330 CALL BCFMAT(J,KR,LR,ISW,KR)                                       LEP08400
      GO TO 105
C     WALL BC                                                           LEP08420
  340 CALL BCWMAT(J,KR,LR,ISW,KR)                                       LEP08430
      IF(J.EQ.JMAX .AND. JMAXBC.EQ.2) CALL BCJMAT(J,KR,LR,ISW)          LEP08440
  105 CONTINUE                                                          LEP08480
C     SET UP MATRIX ELEMENTS FOR USE OF LAGGED B.C.                     LEP08490
C     SINGULAR AXIS L=1 FOR AXISYMMETRIC FLOW                           LEP08500
      IF (IW.NE.1.OR.LORK.NE.LAXIS) GO TO 115                           LEP08510
      DO 110 K=KLORLL,KUORLU                                            LEP08520
  110 CALL ZERODQ(K)                                                    LEP08530
  115 IF(IW.EQ.2.AND.LAXIS.EQ.1) CALL ZERODQ(1)                         LEP08540
C
C      NOZZLE LIP WALL POINTS AT JMAX FOR JMAXBC=2
C      (OUTFLOW B.C. P=FSP IMPOSED)
C
      IF(JMAXBC.NE.2.OR.J.NE.JMAX) GO TO 700
      IF(KPLANE.EQ.1.AND.ISW.EQ.2) GO TO 700
      IF(ITW.EQ.1) GO TO 700
C
C      WALL AT LORK=LORKMX
C
  630 IF(LORK.NE.LORKMX) GO TO 680
      IF(LKMXBC.NE.1) GO TO 680
      DO 670 K=KLOROLL,KORLMX
  670 CALL ZERODQ(K)
  680 CONTINUE
C
C      WALL AT KORL=KORLMX
C
      IF(KLMXBC.EQ.1) CALL ZERODQ(KORLMX)
  700 CONTINUE
C     INTERNAL CORNER AT K,L=KMAX,LMAX                                  LEP08550
      IF (LKMXBC*KLMXBC.NE.1) GO TO 120                                 LEP08560
      IF (LORK.NE.LORKMX) GO TO 120                                     LEP08570
      CALL ZERODQ(KORLMX)                                               LEP08580
C     CORNERS IN PLANE LORK=1                                           LEP08590
  120 IF (LORK.NE.1) GO TO 125                                          LEP08600
C     CORNER AT (K,L)=(1,1)                                             LEP08610
      IF(J.GE.MAX0(JLK1WL,JKL1WL).AND.J.LE.MIN0(JLK1WU,JKL1WU))         LEP08620
     1     CALL ZERODQ(1)                                               LEP08630
C     CORNER WHERE PLUG INTERSECTS SIDEWALL                             LEP08640
      IF (KORLW.LE.0) GO TO 125                                         LEP08650
      IF(J.GE.JLK1WL.AND.J.LE.JLK1WU) CALL ZERODQ(KORLW)                LEP08660
C     TRAILING EDGES OF LONE INTERMEDIATE WALLS                         LEP08670
  125 IF (KORLW.GT.0) GO TO 135                                         LEP08680
C     TRAILING EDGE OF LONE HORIZONTAL WALL                             LEP08690
      IF (LORKW.LE.0.OR.J.NE.JLKW) GO TO 175                            LEP08700
      IF (LORK.NE.LORKW.AND.LORK.NE.LORKW+1) GO TO 175                  LEP08710
      DO 130 K=KLORLL,KUORLU                                            LEP08720
  130 CALL ZERODQ(K)                                                    LEP08730
      GO TO 175                                                         LEP08740
C     TRAILING EDGE OF LONE VERTICAL WALL                               LEP08750
  135 IF (LORKW.GT.0) GO TO 140                                         LEP08760
      IF (J.NE.JKLW) GO TO 175                                          LEP08770
      CALL ZERODQ(KORLW)                                                LEP08780
      CALL ZERODQ(KORLW+1)                                              LEP08790
      GO TO 175                                                         LEP08800
C     EDGES AND CORNERS OF COEXISTENT INTERMEDIATE WALLS                LEP08810
  140 IF (LORK.GT.LORKW) GO TO 160                                      LEP08820
      IF (J.NE.JKLW) GO TO 145                                          LEP08830
C     TRAILING EDGE OF VERTICAL SIDEPLATE                               LEP08840
      CALL ZERODQ(KORLW)                                                LEP08850
      CALL ZERODQ(KORLW+1)                                              LEP08860
C     CORNERS AND EDGES ON LOWER SURFACE OF HORIZONTAL WALL             LEP08870
  145 IF (LORK.NE.LORKW) GO TO 175                                      LEP08880
C     INTERSECTION OF HORIZONTAL WALL AND SIDEPLATE                     LEP08890
      IF(J.LE.MIN0(JKLW,JLKW)) CALL ZERODQ(KORLW)                       LEP08900
C     INTERSECTION OF HORIZONTAL WALL AND VERTICAL PLUG                 LEP08910
      IF(JKL1WL.LE.J.AND.J.LE.JKL1WU) CALL ZERODQ(1)                    LEP08920
C     TRAILING EDGE OF HORIZONTAL WALL                                  LEP08930
      IF (J.NE.JLKW) GO TO 155                                          LEP08940
      K2=KORLW                                                          LEP08950
      IF(JLKW.GT.JKLW) K2=KORLW+1                                       LEP08960
      DO 150 K=1,K2                                                     LEP08970
  150 CALL ZERODQ(K)                                                    LEP08980
C     INSIDE OF PROTRUDING SIDEPLATE                                    LEP08990
  155 IF(JKLW.LE.J.AND.J.LE.JLKW) CALL ZERODQ(KORLW+1)                  LEP09000
      GO TO 175                                                         LEP09010
  160 IF (LORK.GT.LORKW+1) GO TO 175                                    LEP09020
C     CORNERS AND EDGES ON UPPER SURFACE OF HORIZONTAL WALL             LEP09030
C     INTERSECTION WITH VERTICAL WALL                                   LEP09040
      IF(J.LE.MAX0(JKLW,JLKW))CALL ZERODQ(KORLW+1)                      LEP09050
C     TRAILING EDGE                                                     LEP09060
      IF (J.NE.JLKW) GO TO 170                                          LEP09070
      DO 165 K=1,KORLW                                                  LEP09080
  165 CALL ZERODQ(K)                                                    LEP09090
C     INSIDE EDGE OF PROTRUDING SIDEPLATE                               LEP09100
  170 IF(JLKW.LE.J.AND.J.LE.JKLW) CALL ZERODQ(KORLW)                    LEP09110
  175 CONTINUE                                                          LEP09120
C     PRESERVE INITIAL DATA AT INFLOW PLANE J=1 IN REGION OUTSIDE NOZZLELEP09130
      IF(J.NE.1) GO TO 800                                              LEP09140
      IF(LORKW) 755,755,775                                             LEP09150
  755 IF(KORLW.LE.0) GO TO 800                                          LEP09160
  760 K1=KORLW+1                                                        LEP09170
  765 DO 770 K=K1,KORLMX                                                LEP09180
  770 CALL ZERODQ(K)                                                    LEP09190
      GO TO 800                                                         LEP09200
  775 IF(LORK-LORKW) 780,780,785                                        LEP09210
  780 IF(KORLW.LE.0) GO TO 800                                          LEP09220
      GO TO 760                                                         LEP09230
  785 K1=1                                                              LEP09240
      GO TO 765                                                         LEP09250
  800 CONTINUE                                                          LEP09260
      RETURN                                                            LEP09270
      END                                                               LEP09280
*DECK BCFMAT                                                            LEP09290
      SUBROUTINE BCFMAT(J,K,L,ISW,JK)                                   LEP09300
*CALL BASE                                                              LEP09310
*CALL VARS1                                                             LEP09320
*CALL BTRID                                                             LEP09330
*CALL VARS2                                                             LEP09340
      COMMON/FREESP/FSP,FSRHO                                           LEP09350
C                                                                       LEP09360
C     IMPLICIT MATRIX DEFINITIONS FOR ALGEBRAIC FREESTREAM BC AT LORK=LOLEP09370
C     ISW=1,2,3 FOR THE ADI SWEEPS IN J,K,L DIRECTIONS,RESP. THE SWEEPS LEP09380
C   MUST BE PERFORMED IN THE ORDER J,K,L.                               LEP09390
C                                                                       LEP09400
C     ENFORCE FREESTREAM AXIAL VELOCITY U=FSMACH, PRESSURE FSP,         LEP09410
C     AND DENSITY FSRHO AT J,K,L.                                       LEP09420
C                                                                       LEP09430
      RR=1.0/Q(L,1,JK)                                                  LEP09440
      U=Q(L,2,JK)*RR                                                    LEP09450
      V=Q(L,3,JK)*RR                                                    LEP09460
      W=Q(L,4,JK)*RR                                                    LEP09470
      XKE=0.5*(U**2+V**2+W**2)                                          LEP09480
      PJAY=GD*(Q(L,5,JK)-XKE*Q(L,1,JK))                                 LEP09490
      PFSJAY=FSP                                                        LEP09500
      RFSJAY=FSRHO                                                      LEP09510
      I=L                                                               LEP09520
      IF (ISW-2) 15,20,25                                               LEP09530
   15 I=J                                                               LEP09540
      GO TO 25                                                          LEP09550
   20 I=K                                                               LEP09560
   25 DO 30 M=1,5                                                       LEP09570
      A(I,1,M)=0.0                                                      LEP09580
      B(I,1,M)=0.0                                                      LEP09590
      C(I,1,M)=0.0                                                      LEP09600
      A(I,2,M)=0.0                                                      LEP09610
      B(I,2,M)=0.0                                                      LEP09620
      C(I,2,M)=0.0                                                      LEP09630
      A(I,5,M)=0.0                                                      LEP09640
      B(I,5,M)=0.0                                                      LEP09650
   30 C(I,5,M)=0.0                                                      LEP09660
      B(I,1,1)=1.0*Q6(L,JK)                                             LEP09670
      B(I,2,1)=-FSMACH*Q6(L,JK)                                         LEP09680
      B(I,2,2)=1.0*Q6(L,JK)                                             LEP09690
      B(I,5,1)=XKE*Q6(L,JK)                                             LEP09700
      B(I,5,2)=-U*Q6(L,JK)                                              LEP09710
      B(I,5,3)=-V*Q6(L,JK)                                              LEP09720
      B(I,5,4)=-W*Q6(L,JK)                                              LEP09730
      B(I,5,5)=1.0*Q6(L,JK)                                             LEP09740
      IF (ISW-2) 35,40,40                                               LEP09750
   35 F(I,2)=(FSMACH*Q(L,1,JK)-Q(L,2,JK))*Q6(L,JK)                      LEP09760
      F(I,5)=((PFSJAY-PJAY)/GD)*Q6(L,JK)                                LEP09770
      F(I,1)=(RFSJAY-Q(L,1,JK))*Q6(L,JK)                                LEP09780
      RETURN                                                            LEP09790
   40 DO 45 N=1,4                                                       LEP09800
   45 F(I,5)=F(I,5)+B(I,5,N)*F(I,N)/Q6(L,JK)                            LEP09810
      F(I,2)=(B(I,2,1)*F(I,1)+B(I,2,2)*F(I,2))/Q6(L,JK)                 LEP09820
      F(I,1)=(B(I,1,1)*F(I,1))/Q6(L,JK)                                 LEP09830
      RETURN                                                            LEP09840
      END                                                               LEP09850
*DECK BCJMAT                                                            LEP09860
      SUBROUTINE BCJMAT(J,K,L,ISW)                                      LEP09870
*CALL BASE                                                              LEP09880
*CALL VARS1                                                             LEP09890
*CALL BTRID                                                             LEP09900
C     COMMON FREESP CONTAINS FREESTREAM PRESSURE                        LEP09910
      COMMON/FREESP/FSP                                                 LEP09920
*CALL VARS2                                                             LEP09930
C     IMPLICIT MATRIX DEFINITIONS FOR ALGEBRAIC B.C. AT J=1,JMAX.       LEP09940
C     ISW=1,2,3 FOR THE ADI SWEEPS IN J,K,L DIRECTIONS,RESP. THE SWEEPS LEP09950
C   MUST BE PERFORMED IN THE ORDER J,K,L.                               LEP09960
      JK=J                                                              LEP09970
      IF(ISW.GT.1) JK=K                                                 LEP09980
      RR=1.0/Q(L,1,JK)                                                  LEP09990
      U=Q(L,2,JK)*RR                                                    LEP10000
      V=Q(L,3,JK)*RR                                                    LEP10010
      W=Q(L,4,JK)*RR                                                    LEP10020
      XKE=0.5*(U**2+V**2+W**2)                                          LEP10030
      PJAY=GD*(Q(L,5,JK)-XKE*Q(L,1,JK))                                 LEP10040
      PFSJAY=FSP                                                        LEP10050
      I=L                                                               LEP10060
      IF (ISW-2) 10,15,20                                               LEP10070
   10 I=J                                                               LEP10080
      GO TO 20                                                          LEP10090
   15 I=K                                                               LEP10100
   20 IF (J-1) 50,50,25                                                 LEP10110
   25 IF (JMAXBC.NE.2) GO TO 145                                        LEP10120
C   ENFORCE FREESTREAM PRESSURE B.C. P=FSP AT OUTFLOW                   LEP10130
C   BOUNDARY J=JMAX (INPUT OPTION JMAXBC=2)                             LEP10140
C                                                                       LEP10150
C     THIS ALGEBRAIC B.C. IS USED IN PLACE OF THE ENERGY EQUATION TO    LEP10160
C     MAINTAIN CONSISTENCY WITH THE WALL B.C. AT WALL POINTS            LEP10170
C                                                                       LEP10180
      IF(L.EQ.LMAX.AND.LMAXBC.EQ.1) GO TO 26
      IF(K.EQ.KMAX.AND.KMAXBC.EQ.1) GO TO 26
      GO TO 300
   26 CONTINUE
      DO 30 M=1,5                                                       LEP10190
      A(I,5,M)=0.0                                                      LEP10200
      B(I,5,M)=0.0                                                      LEP10210
   30 C(I,5,M)=0.0                                                      LEP10220
      B(I,5,1)=XKE*Q6(L,JK)                                             LEP10230
      B(I,5,2)=-U*Q6(L,JK)                                              LEP10240
      B(I,5,3)=-V*Q6(L,JK)                                              LEP10250
      B(I,5,4)=-W*Q6(L,JK)                                              LEP10260
      B(I,5,5)=1.0*Q6(L,JK)                                             LEP10270
      IF (ISW-2) 35,40,40                                               LEP10280
   35 F(I,5)=(PFSJAY-PJAY)/GD*Q6(L,JK)                                  LEP10290
      GO TO 145                                                         LEP10300
   40 FSVP=0.0                                                          LEP10310
      DO 45 M=1,5                                                       LEP10320
   45 FSVP=FSVP+B(I,5,M)*F(I,M)                                         LEP10330
      F(I,5)=FSVP/Q6(L,JK)                                              LEP10340
C ENFORCE WALL TEMPERATURE B.C. AT WALL POINTS OF THE OUTFLOW BOUNDARY  LEP10350
C     WHEN TW.GT.0 .  THE ALGEBRAIC B.C. RHO*TW=GAMMA*(GAMMA-1.)*EPSLON LEP10360
C     REPLACES THE CONTINUITY EQUATION IN THIS CASE.                    LEP10370
  300 IF(ITW.EQ.0) GO TO 145                                            LEP10380
      THW=TW/GD                                                         LEP10390
      IF(L-LMAX) 46,47,145                                              LEP10400
   46 IF(K-KMAX) 145,47,145                                             LEP10410
   47 DO 200 M=1,5                                                      LEP10420
      A(I,1,M)=0.                                                       LEP10430
      B(I,1,M)=0.                                                       LEP10440
  200 C(I,1,M)=0.                                                       LEP10450
      B(I,1,1)=THW*Q6(L,JK)                                             LEP10460
      B(I,1,5)=-Q6(L,JK)                                                LEP10470
      F(I,5)=0.                                                         LEP10480
      GO TO 145                                                         LEP10490
C     FOR INPUT OPTION J1BC=1, WE                                       LEP10500
C   ENFORCE TWO IMPLICIT INFLOW B.C.AT J=1 ON VELOCITY VECTOR DIREC-    LEP10510
C   TION COSINES V/U,W/U. THESE REPLACE THE V,W MOMENTUM EQ'S.,RESP.    LEP10520
C     FOR OPTION J1BC=2, WE COMPUTE V,W FROM THEIR MOMENTUM EQUATIONS.  LEP10530
   50 IF (J1BC.GT.1) GO TO 70                                           LEP10540
      DO 55 N=3,4                                                       LEP10550
      DO 55 M=1,5                                                       LEP10560
      A(I,N,M)=0.0                                                      LEP10570
      B(I,N,M)=0.0                                                      LEP10580
      C(I,N,M)=0.0                                                      LEP10590
   55 CONTINUE                                                          LEP10600
      B(I,3,2)=-VOU(L,K)*Q6(L,JK)                                       LEP10610
      B(I,3,3)=Q6(L,JK)                                                 LEP10620
      B(I,4,2)=-WOU(L,K)*Q6(L,JK)                                       LEP10630
      B(I,4,4)=Q6(L,JK)                                                 LEP10640
      IF (ISW-2) 60,65,65                                               LEP10650
   60 F(I,3)=(VOU(L,K)*Q(L,2,JK)-Q(L,3,JK))*Q6(L,JK)                    LEP10660
      F(I,4)=(WOU(L,K)*Q(L,2,JK)-Q(L,4,JK))*Q6(L,JK)                    LEP10670
      GO TO 70                                                          LEP10680
   65 F(I,3)=(B(I,3,2)*F(I,2)+B(I,3,3)*F(I,3))/Q6(L,JK)                 LEP10690
      F(I,4)=(B(I,4,2)*F(I,2)+B(I,4,4)*F(I,4))/Q6(L,JK)                 LEP10700
C   ENFORCE TWO IMPLICIT INFLOW B.C. ON TOTAL ENTHALPY HTOT AND TOTAL   LEP10710
C   PRESSURE PTOT. J1BC.LT.0 SELECTS AN MOC RELATION TO CLOSE THE       LEP10720
C   SYSTEM. FOR J1BC.GT.0 THE SYSTEM IS CLOSED WITH EITHER THE CONTINU  LEP10730
C   ITY, THE U-MOMENTUM, OR THE ENERGY EQUATION BY DEFINING NX=1,2,OR   LEP10740
C   5, RESP.                                                            LEP10750
C     FOR J1BC=3 THE U-MOMENTUM EQ. IS REPLACED BY THE IMPLICIT RELATIONLEP10760
C     D(U)/D(XI)=0                                                      LEP10770
   70 IF (J1BC) 75,80,80                                                LEP10780
   75 NX=1                                                              LEP10790
      NPT=2                                                             LEP10800
      NHT=5                                                             LEP10810
C   MOC RELATION FOR B(I,NX,M), C(I,NX,M),F(I,NX) GOES HERE             LEP10820
      GO TO 105                                                         LEP10830
   80 CONTINUE                                                          LEP10840
C   DEFINE NX FOR J1BC.GT.0                                             LEP10850
      NX=INXBC                                                          LEP10860
      IF (LW.LE.0) GO TO 85                                             LEP10870
      KR=KMAX                                                           LEP10880
      IF(KW.GT.0) KR=KW                                                 LEP10890
      IF(K.GT.KR) GO TO 85                                              LEP10900
      IF(L.EQ.LW .OR. L.EQ.LW+1) NX=2                                   LEP10910
   85 IF (KW.LE.0) GO TO 90                                             LEP10920
      LR=LMAX                                                           LEP10930
      IF(LW.GT.0) LR=LW                                                 LEP10940
      IF(L.GT.LR) GO TO 90                                              LEP10950
      IF(K.EQ.KW.OR.K.EQ.KW+1) NX=2                                     LEP10960
   90 IF(L.EQ.LMAX .AND. LMAXBC.EQ.1) NX=2                              LEP10970
      IF(K.EQ.KMAX .AND. KMAXBC.EQ.1) NX=2                              LEP10980
      IF(L.EQ.1 .AND. L1BC.EQ.1 .AND. JL1WL.LE.J .AND. J.LE.JL1WU) NX=2 LEP10990
      IF(K.EQ.1 .AND. K1BC.EQ.1 .AND. JK1WL.LE.J .AND. J.LE.JK1WU) NX=2 LEP11000
      NPT=2                                                             LEP11010
      NHT=5                                                             LEP11020
      IF (NX-2) 105,95,100                                              LEP11030
   95 NPT=1                                                             LEP11040
      GO TO 105                                                         LEP11050
  100 NPT=1                                                             LEP11060
      NHT=2                                                             LEP11070
  105 DO 110 M=1,5                                                      LEP11080
      A(I,NPT,M)=0.0                                                    LEP11090
      B(I,NPT,M)=0.0                                                    LEP11100
      C(I,NPT,M)=0.0                                                    LEP11110
      A(I,NHT,M)=0.0                                                    LEP11120
      B(I,NHT,M)=0.0                                                    LEP11130
  110 C(I,NHT,M)=0.0                                                    LEP11140
      JK=JK                                                             LEP11150
      HG=HTOT(L,K)/GAMI                                                 LEP11160
      IF (J1BC.EQ.3) GO TO 115                                          LEP11170
      GCR=HG*(Q(L,1,JK)*HTOT(L,K)/PTOT(L,K))**GAMI                      LEP11180
      B(I,NPT,1)=(XKE-GCR)*Q6(L,JK)                                     LEP11190
      B(I,NPT,2)=-U*Q6(L,JK)                                            LEP11200
      B(I,NPT,3)=-V*Q6(L,JK)                                            LEP11210
      B(I,NPT,4)=-W*Q6(L,JK)                                            LEP11220
      B(I,NPT,5)=1.0*Q6(L,JK)                                           LEP11230
      GO TO 125                                                         LEP11240
  115 IF (ISW.GE.2) GO TO 120                                           LEP11250
      B(I,NPT,1)=Q(L,2,JK)/Q(L,1,JK)**2                                 LEP11260
      B(I,NPT,2)=-1.0/Q(L,1,JK)                                         LEP11270
      C(I,NPT,1)=-Q(L,2,JK+1)/Q(L,1,JK+1)**2                            LEP11280
      C(I,NPT,2)=1.0/Q(L,1,JK+1)                                        LEP11290
      GO TO 125                                                         LEP11300
  120 B(I,NPT,2)=1.0                                                    LEP11310
  125 B(I,NHT,1)=(HG-GAMI*XKE)*Q6(L,JK)                                 LEP11320
      B(I,NHT,2)=GAMI*U*Q6(L,JK)                                        LEP11330
      B(I,NHT,3)=GAMI*V*Q6(L,JK)                                        LEP11340
      B(I,NHT,4)=GAMI*W*Q6(L,JK)                                        LEP11350
      B(I,NHT,5)=-GAMMA*Q6(L,JK)                                        LEP11360
      IF (ISW-2) 130,135,135                                            LEP11370
  130 IF(J1BC.LE.2) F(I,NPT)=((XKE+(GCR/GAMMA))*Q(L,1,JK)-Q(L,5,JK))    LEP11380
     1    *Q6(L,JK)                                                     LEP11390
      IF(J1BC.EQ.3)F(I,NPT)=(Q(L,2,JK)/Q(L,1,JK)-Q(L,2,JK+1)/Q(L,1,JK+1)LEP11400
     1)*Q6(L,JK)                                                        LEP11410
      F(I,NHT)=(GAMMA*Q(L,5,JK)-Q(L,1,JK)*(HG+GAMI*XKE))*Q6(L,JK)       LEP11420
      GO TO 145                                                         LEP11430
  135 FSVP=0.0                                                          LEP11440
      FSVH=0.0                                                          LEP11450
      DO 140 M=1,5                                                      LEP11460
      FSVP=FSVP+B(I,NPT,M)*F(I,M)                                       LEP11470
  140 FSVH=FSVH+B(I,NHT,M)*F(I,M)                                       LEP11480
      F(I,NPT)=FSVP/Q6(L,JK)                                            LEP11490
      F(I,NHT)=FSVH/Q6(L,JK)                                            LEP11500
  145 RETURN                                                            LEP11510
      END                                                               LEP11520
*DECK BCLKMX                                                            LEP11530
      SUBROUTINE BCLKMX(IWW,JJ,K)                                       LEP11540
*CALL BASE                                                              LEP11550
*CALL VARS1                                                             LEP11560
*CALL BTRID                                                             LEP11570
*CALL RHSBCC                                                            LEP11580
*CALL VARS2                                                             LEP11590
C     IMPLICIT OUTFLOW BOUNDARY CONDITIONS (LORKMXBC=2 OR 5),OR WALL BC LEP11600
C   (LKMXBC=3), OR SYMMETRY BC (LKMXBC=3,4) AT GRID POINTS L=LORKMX.    LEP11610
C     IMPLICIT WALL BC INTERMEDIATE WALL LOWER SURFACE L=LORKW,J.LE.JLKWLEP11620
C     FILLS IN LAST ROW OF BLOCK - TRIDIAGONAL COEFFICIENT MATRIX TO    LEP11630
C    ACCOUNT FOR IMPLICIT PORTION OF INVISCID FLUX VECTOR TERMS, AND    LEP11640
C   FILLS INLAST ROW OF RIGHT HAND SIDE VECTOR AS COMPUTED IN SUBR.     LEP11650
C   RHS. THE IMPLICIT PORTION OF THE VISCOUS TERMS FOR THE ZETA(L)      LEP11660
C    OR ETA(K)  DIRECTION ARE ADDED IN BY SUBROUTINE VISMAT.            LEP11670
      IW=IWW                                                            LEP11680
      J=JJ                                                              LEP11690
      CALL SW                                                           LEP11700
      LKWR=LORKW+1                                                      LEP11710
      KLWR=KORLW+1                                                      LEP11720
      INTWAL=0                                                          LEP11730
      IF(LORKW.GT.0.AND.J.LE.JLKW) INTWAL=1                             LEP11740
      IF(KORLW.GT.0.AND.K.GE.KLWR) INTWAL=0                             LEP11750
C     BC AT UPPER BOUNDARY LORKMX                                       LEP11760
      L=LORKMX                                                          LEP11770
  100 LORK=L                                                            LEP11780
      KORL=K                                                            LEP11790
      LMM=L-1
      KMM=K
      IF(IW.EQ.1) GO TO 200                                             LEP11820
      LORK=K                                                            LEP11830
      KORL=L                                                            LEP11840
      LMM=LORK
      KMM=KORL-1
  200 CONTINUE                                                          LEP11870
      RJ=Q6(LORK,KORL)                                                  LEP11880
      RR = RM * (RJ+Q6(LMM,KMM))                                        LEP11890
      IF(L.EQ.LORKMX.AND.(LKMXBC.EQ.3.OR.LKMXBC.EQ.4)) GO TO 500        LEP11900
      DO 400 N=1,5                                                      LEP11910
      DO 300 M=1,5                                                      LEP11920
      C(L,N,M)=0.0                                                      LEP11930
      A(L,N,M) = -2.0*D(L-1,N,M)                                        LEP11940
  300 B(L,N,M) = 2.0*D(L,N,M)                                           LEP11950
      A(L,N,N) = A(L,N,N) +(-RR+(1.0-WTFAC)*RJ)                         LEP11960
      B(L,N,N) = WTFAC*RJ + RR + B(L,N,N)                               LEP11970
  400 F(L,N) = S(LORK,N+8,KORL)                                         LEP11980
C     SYMMETRY BC FOR INVISCID TERMS AT UPPER BOUNDARY LORKMX           LEP11990
      IF(L-LORKMX) 900,850,850                                          LEP12000
  500 DO 700 N=1,5                                                      LEP12010
      DO 600 M=1,5                                                      LEP12020
      C(L,N,M)=0.0                                                      LEP12030
      B(L,N,M)=0.0                                                      LEP12040
  600 A(L,N,M)=-2.0*D(L-1,N,M)                                          LEP12050
      B(L,N,N)=Q6(LORK,KORL)+RR                                         LEP12060
      A(L,N,N)=A(L,N,N)-RR                                              LEP12070
  700 F(L,N)=S(LORK,N+8,KORL)                                           LEP12080
      DO 800 M=1,5                                                      LEP12090
      A(L,LKMXBC,M)=0.0                                                 LEP12100
  800 F(L,LKMXBC)=0.0                                                   LEP12110
C     BC AT INTERMEDIATE WALL                                           LEP12120
  850 IF(INTWAL.EQ.0) GO TO 900                                         LEP12130
      L=LORKW                                                           LEP12140
      GO TO 100                                                         LEP12150
  900 RETURN                                                            LEP12160
      END                                                               LEP12170
*DECK BCLK1                                                             LEP12180
      SUBROUTINE BCLK1(IWW,JJ,K)                                        LEP12190
*CALL BASE                                                              LEP12200
*CALL VARS1                                                             LEP12210
*CALL BTRID                                                             LEP12220
*CALL RHSBCC                                                            LEP12230
*CALL VARS2                                                             LEP12240
C   IMPLICIT WALL BC AT GRID POINTS LK=1 AND J.GE.JLK1WL.OR.J.LE.JLK1WU LEP12250
C     AND SYMMETRY BC OUTSIDE THAT J INTERVAL INPLICIT WALL BC AT       LEP12260
C     INTERMEDIATE WALL UPPER SURFACE L=LORKW+1 AND J.LE.JLKW.          LEP12270
C   FILLS IN FIRST ROW OF COEFFICIENT MATRIX TO ACCOUNT FOR IMPLICIT    LEP12280
C   PORTION OF INVISCID FLUX VECTOR TERMS, AND FILLS IN FIRST ROW OF    LEP12290
C   RIGHT HAND SIDE VECTOR AS COMPUTED IN SUBROUTINE RHS. FOR           LEP12300
C   ADIABATIC WALL, THE IMPLICIT PORTION OF THE VISCOUS TERMS IN THE    LEP12310
C   ENERGY EQ FOR ZETA(L) OR ETA(K) DIRECTION ARE ADDED BY SUBR VISMAT. LEP12320
C     THE EXTRA MATRIX MULTIPLY THAT ACCOUNTS FOR ZERO VELOCITY B.C.    LEP12330
C   AND FOR PRESCRIBED WALL TEMP BC (ITW=1) IS PERFORMED IN  SUBR BCWMATLEP12340
      IW=IWW                                                            LEP12350
      J=JJ                                                              LEP12360
      CALL SW                                                           LEP12370
      LKWR=LORKW+1                                                      LEP12380
      KLWR=KORLW+1                                                      LEP12390
      INTWAL=0                                                          LEP12400
      IF(LORKW.GT.0.AND.J.LE.JLKW) INTWAL=1                             LEP12410
      IF(KORLW.GT.0.AND.K.GE.KLWR) INTWAL=0                             LEP12420
C     BC AT L=1                                                         LEP12430
      L=1                                                               LEP12440
   50 LORK=L                                                            LEP12450
      KORL=K                                                            LEP12460
      LP=L+1                                                            LEP12470
      KP=K                                                              LEP12480
      IF(IW.EQ.1) GO TO 75                                              LEP12490
      LORK=K                                                            LEP12500
      KORL=L                                                            LEP12510
      LP=LORK                                                           LEP12520
      KP=KORL+1                                                         LEP12530
   75 RJ=Q6(LORK,KORL)                                                  LEP12540
      RF=RM*(RJ+Q6(LP,KP))                                              LEP12550
C     BC AT L=1                                                         LEP12560
      IF(L.GT.1) GO TO 150                                              LEP12570
C     TEST FOR INTERMEDIATE WALL NORMAL TO L=1 SURFACE                  LEP12580
      IF(KORLW) 100,100,130                                             LEP12590
C     TEST FOR WALL AT L=1                                              LEP12600
  100 IF(JLK1WL.LE.J.AND.J.LE.JLK1WU) GO TO 150                         LEP12610
C     SYMMETRY                                                          LEP12620
      GO TO 190                                                         LEP12630
C     TEST FOR WALL AT L=1                                              LEP12640
  130 IF(K-KORLW) 100,100,190                                           LEP12650
  150 DO 180 N=1,5                                                      LEP12660
      DO 170 M=1,5                                                      LEP12670
      A(L,N,M)=0.0                                                      LEP12680
      B(L,N,M)=-2.0*D(L,N,M)                                            LEP12690
  170 C(L,N,M)=2.0*D(L+1,N,M)                                           LEP12700
      B(L,N,N)=B(L,N,N)+(WTFAC*RJ+RF)                                   LEP12710
      C(L,N,N)=C(L,N,N)+(-RF+(1.0-WTFAC)*RJ)                            LEP12720
  180 F(L,N)=S(LORK,N+8,KORL)                                           LEP12730
      IF(L.EQ.1) GO TO 250                                              LEP12740
C                                                                       LEP12750
C   SYM BC J.LT.JLK1WL.OR.J.GT.JLK1WU FOR INVISCID TERMS AT LWER BDY L=1LEP12760
C                                                                       LEP12770
  190 IF(L.GT.1) GO TO 300                                              LEP12780
      DO 210 N=1,5                                                      LEP12790
      DO 200 M=1,5                                                      LEP12800
      A(L,N,M)=0.0                                                      LEP12810
      B(L,N,M)=0.0                                                      LEP12820
  200 C(L,N,M)=2.0*D(L+1,N,M)                                           LEP12830
      B(L,N,N)=Q6(LORK,KORL)+RF                                         LEP12840
      C(L,N,N)=C(L,N,N)-RF                                              LEP12850
  210 F(L,N)=S(LORK,N+8,KORL)                                           LEP12860
      IF(IW.EQ.2) GO TO 230                                             LEP12870
      DO 220 M=1,5                                                      LEP12880
  220 C(L,4,M)=0.0                                                      LEP12890
      F(L,4)=0.0                                                        LEP12900
      GO TO 250                                                         LEP12910
  230 DO 240 M=1,5                                                      LEP12920
  240 C(L,3,M)=0.0                                                      LEP12930
      F(L,3)=0.0                                                        LEP12940
C     BC AT INTERMEDIATE WALL                                           LEP12950
  250 IF(INTWAL.EQ.0) GO TO 300                                         LEP12960
      L=LKWR                                                            LEP12970
      GO TO 50                                                          LEP12980
  300 RETURN                                                            LEP12990
      END                                                               LEP13000
*DECK BCWMAT                                                            LEP13010
      SUBROUTINE BCWMAT(J,K,L,ISW,JK)                                   LEP13020
*CALL BASE                                                              LEP13030
*CALL VARS1                                                             LEP13040
*CALL BTRID                                                             LEP13050
*CALL VARS2                                                             LEP13060
C                                                                       LEP13070
C     IMPLICIT MATRIX DEFINITIONS FOR ALGEBRAIC WALL BC AT (J,K,L)      LEP13080
C     ISW=1,2,3 FOR THE ADI SWEEPS IN J,K,L DIRECTIONS,RESP. THE SWEEPS LEP13090
C   MUST BE PERFORMED IN THE ORDER J,K,L.                               LEP13100
C                                                                       LEP13110
      IF (ITW) 10,10,40                                                 LEP13120
C     VELOCITY B.C. FOR ADIABATIC WALL AND ZERO MASS TRANSFER           LEP13130
   10 I=L                                                               LEP13140
      IF (ISW-2) 15,20,25                                               LEP13150
   15 I=J                                                               LEP13160
      GO TO 25                                                          LEP13170
   20 I=K                                                               LEP13180
   25 DO 30 N=2,4                                                       LEP13190
      DO 30 M=1,5                                                       LEP13200
      A(I,N,M)=0.0                                                      LEP13210
      B(I,N,M)=0.0                                                      LEP13220
      C(I,N,M)=0.0                                                      LEP13230
   30 CONTINUE                                                          LEP13240
      DO 35 N=2,4                                                       LEP13250
      F(I,N)=0.0                                                        LEP13260
   35 B(I,N,N)=Q6(L,JK)                                                 LEP13270
      RETURN                                                            LEP13280
C     VELOCITY AND TEMPERATURE B.C. FOR PRESCRIBED WALL TEMP. TW AND    LEP13290
C   NORMAL MASS INJECTION RATE WMDOT                                    LEP13300
C   ZETA(L) DIRECTION IS ASSUMED NORMAL  TO WALL                        LEP13310
C   WMDOT IS ASSUMED ZERO BELOW                                         LEP13320
C                                                                       LEP13330
   40 THW=TW/GD                                                         LEP13340
      I=L                                                               LEP13350
      IF (ISW-2) 45,50,55                                               LEP13360
   45 I=J                                                               LEP13370
      GO TO 55                                                          LEP13380
   50 I=K                                                               LEP13390
   55 DO 65 N=2,5                                                       LEP13400
      DO 60 M=1,5                                                       LEP13410
      A(I,N,M)=0.0                                                      LEP13420
      B(I,N,M)=0.0                                                      LEP13430
   60 C(I,N,M)=0.0                                                      LEP13440
   65 B(I,N,N)=Q6(L,JK)                                                 LEP13450
      B(I,5,1)=THW*Q6(L,JK)                                             LEP13460
      B(I,5,5)=-Q6(L,JK)                                                LEP13470
      DO 70 N=2,5                                                       LEP13480
   70 F(I,N)=0.0                                                        LEP13490
      RETURN                                                            LEP13500
      END                                                               LEP13510
*DECK BCXIN                                                             LEP13520
      SUBROUTINE BCXIN(L)                                               LEP13530
*CALL BASE                                                              LEP13540
*CALL VARS1                                                             LEP13550
*CALL BTRID                                                             LEP13560
*CALL VARS2                                                             LEP13570
C       IMPLICIT INFLOW B.C. AT GRID POINTS J=1                         LEP13580
C   FILLS IN FIRST ROW OF COEFFICIENT MATRIX TO ACCOUNT FOR IMPLICIT    LEP13590
C   PORTION OF INVISCID FLUX VECTOR TERMS, AND FILLS IN FIRST ROW OF    LEP13600
C   RIGHT HAND SIDE VECTOR AS COMPUTED IN SUBRS. RHS AND VISRHS.        LEP13610
C     THE EXTRA MATRIX MULTIPLY THAT ACCOUNTS FOR ALGEBRAIC B.C.        LEP13620
C   IS PERFORMED IN SUBR. BCJMAT                                        LEP13630
C                                                                       LEP13640
      J=1                                                               LEP13650
      JF=J+1                                                            LEP13660
      RJ=Q6(L,J)                                                        LEP13670
      RF=RM * (RJ+Q6(L,JF))                                             LEP13680
      DO 20 N=1,5                                                       LEP13690
      DO 15 M=1,5                                                       LEP13700
      A(J,N,M)=0.0                                                      LEP13710
      B(J,N,M)=-2.0*D(J,N,M)                                            LEP13720
   15 C(J,N,M)=2.0*D(J+1,N,M)                                           LEP13730
      B(J,N,N)=B(J,N,N)+(WTFAC*RJ+RF)                                   LEP13740
      C(J,N,N)=C(J,N,N)+(-RF+(1.0-WTFAC)*RJ)                            LEP13750
   20 F(J,N)=S(L,N+8,J)                                                 LEP13760
   25 RETURN                                                            LEP13770
      END                                                               LEP13780
*DECK BCXOUT                                                            LEP13790
      SUBROUTINE BCXOUT(L)                                              LEP13800
*CALL BASE                                                              LEP13810
*CALL VARS1                                                             LEP13820
*CALL BTRID                                                             LEP13830
*CALL VARS2                                                             LEP13840
C   IMPLICIT OUTFLOW BOUNDARY CONDITIONS IN XI DIRECTION                LEP13850
C   FILL IN LAST ROW OF BLOCK TRIDIAGONAL COEFF MATRIX WITH             LEP13860
C   EQUATION BETWEEN DELTAQ(JMAX) AND DELTAQ(JM).                       LEP13870
C   EQUATION IS FIRST ORDER BACKWARD DIFFERENCING IN XI OF              LEP13880
C   THE P.D.E. AT J=JMAX.                                               LEP13890
C   RIGHT HAND SIDE OF EQUATION IS COMPUTED IN SUBR. RHS                LEP13900
      J=JMAX                                                            LEP13910
      RJ=Q6(L,J)                                                        LEP13920
      RR=RM * (RJ+Q6(L,J-1))                                            LEP13930
      DO 20 N=1,5                                                       LEP13940
      DO 15 M=1,5                                                       LEP13950
      A(J,N,M)=-2.0*D(J-1,N,M)                                          LEP13960
   15 B(J,N,M)=2.0*D(J,N,M)                                             LEP13970
      A(J,N,N)=A(J,N,N)-RR + (1.0-WTFAC)*RJ                             LEP13980
      B(J,N,N)=(WTFAC*RJ+RR)+B(J,N,N)                                   LEP13990
   20 F(J,N)=S(L,N+8,J)                                                 LEP14000
      RETURN                                                            LEP14010
      END                                                               LEP14020
*DECK BTRI                                                              LEP14030
      SUBROUTINE BTRI(IL,IU)                                            LEP14040
*CALL BTRID                                                             LEP14050
      DIMENSION H(5,5)                                                  LEP14060
      REAL L11,L21,L22,L31,L32,L33,L41,L42,L43,L44,L51,L52,L53,L54,L55  LEP14070
      IS=IL+1                                                           LEP14080
      IE=IU-1                                                           LEP14090
C     INSERT LUDEC                                                      LEP14100
      L11=1./B(IL,1,1)                                                  LEP14110
      L21=B(IL,2,1)                                                     LEP14120
      U12=B(IL,1,2)*L11                                                 LEP14130
      L22=1./(B(IL,2,2)-L21*U12)                                        LEP14140
      U13=B(IL,1,3)*L11                                                 LEP14150
      U14 = B(IL,1,4)*L11                                               LEP14160
      U15=B(IL,1,5)*L11                                                 LEP14170
      L31=B(IL,3,1)                                                     LEP14180
      L32=B(IL,3,2)-L31*U12                                             LEP14190
      U23=(B(IL,2,3)-L21*U13)*L22                                       LEP14200
      L33=1./(B(IL,3,3)-U13*L31-U23*L32)                                LEP14210
      U24=(B(IL,2,4)-L21*U14)*L22                                       LEP14220
      U25=(B(IL,2,5)-L21*U15)*L22                                       LEP14230
      L41=B(IL,4,1)                                                     LEP14240
      L42=B(IL,4,2)-L41*U12                                             LEP14250
      L43=B(IL,4,3)-L41*U13-L42*U23                                     LEP14260
      U34=(B(IL,3,4)-L31*U14-L32*U24)*L33                               LEP14270
      L44=1./(B(IL,4,4)-U14*L41-U24*L42-U34*L43)                        LEP14280
      U35=(B(IL,3,5)-L31*U15-L32*U25)*L33                               LEP14290
      L51=B(IL,5,1)                                                     LEP14300
      L52=B(IL,5,2)-L51*U12                                             LEP14310
      L53=B(IL,5,3)-L51*U13-L52*U23                                     LEP14320
      L54=B(IL,5,4)-L51*U14-L52*U24-L53*U34                             LEP14330
      U45=(B(IL,4,5)-L41*U15-L42*U25-L43*U35)*L44                       LEP14340
      L55=1./(B(IL,5,5)-L51*U15-L52*U25-L53*U35-L54*U45)                LEP14350
C     COMPUTE LITTLE R S                                                LEP14360
      D1=L11*F(IL,1)                                                    LEP14370
      D2=L22*(F(IL,2)-L21*D1)                                           LEP14380
      D3=L33*(F(IL,3)-L31*D1-L32*D2)                                    LEP14390
      D4=L44*(F(IL,4)-L41*D1-L42*D2-L43*D3)                             LEP14400
      D5=L55*(F(IL,5)-L51*D1-L52*D2-L53*D3-L54*D4)                      LEP14410
C     COMPUTE BIG R S                                                   LEP14420
      F(IL,5)=D5                                                        LEP14430
      F(IL,4)=D4-U45*D5                                                 LEP14440
      F(IL,3)=D3-U34*F(IL,4)-U35*D5                                     LEP14450
      F(IL,2)=D2-U23*F(IL,3)-U24*F(IL,4)-U25*D5                         LEP14460
      F(IL,1)=D1-U12*F(IL,2)-U13*F(IL,3)-U14*F(IL,4)-U15*D5             LEP14470
C     COMPUTE C PRIME FOR FIRST ROW                                     LEP14480
      DO 10 M=1,5                                                       LEP14490
      D1=L11*C(IL,1,M)                                                  LEP14500
      D2=L22*(C(IL,2,M)-L21*D1)                                         LEP14510
      D3=L33*(C(IL,3,M)-L31*D1-L32*D2)                                  LEP14520
      D4=L44*(C(IL,4,M)-L41*D1-L42*D2-L43*D3)                           LEP14530
      D5=L55*(C(IL,5,M)-L51*D1-L52*D2-L53*D3-L54*D4)                    LEP14540
      B(IL,5,M)=D5                                                      LEP14550
      B(IL,4,M)=D4-U45*D5                                               LEP14560
      B(IL,3,M) = D3-U34*B(IL,4,M)-U35*D5                               LEP14570
      B(IL,2,M) = D2-U23*B(IL,3,M)-U24*B(IL,4,M)-U25*D5                 LEP14580
   10 B(IL,1,M) = D1-U12*B(IL,2,M)-U13*B(IL,3,M)-U14*B(IL,4,M)-U15*D5   LEP14590
      DO 30 I=IS,IE                                                     LEP14600
      IR=I-1                                                            LEP14610
C      COMPUTE B PRIME*BIGR                                             LEP14620
      DO 15 N=1,5                                                       LEP14630
   15 F(I,N)=F(I,N)-A(I,N,1)*F(IR,1)-A(I,N,2)*F(IR,2)-A(I,N,3)*F(IR,3)  LEP14640
     1 -A(I,N,4)*F(IR,4)-A(I,N,5)*F(IR,5)                               LEP14650
C      COMPUTE B PRIME                                                  LEP14660
      DO 20 M=1,5                                                       LEP14670
      DO 20 N=1,5                                                       LEP14680
   20 H(N,M)=B(I,N,M)-A(I,N,1)*B(IR,1,M)-A(I,N,2)*B(IR,2,M)-A(I,N,3)    LEP14690
     1 *B(IR,3,M)-A(I,N,4)*B(IR,4,M)-A(I,N,5)*B(IR,5,M)                 LEP14700
C     INSERT LUDEC AGAIN                                                LEP14710
      L11=1./H(1,1)                                                     LEP14720
      L21=H(2,1)                                                        LEP14730
      U12=H(1,2)*L11                                                    LEP14740
      L22=1./(H(2,2)-L21*U12)                                           LEP14750
      U13=H(1,3)*L11                                                    LEP14760
      U14=H(1,4)*L11                                                    LEP14770
      U15=H(1,5)*L11                                                    LEP14780
      L31=H(3,1)                                                        LEP14790
      L32=H(3,2)-L31*U12                                                LEP14800
      U23=(H(2,3)-L21*U13)*L22                                          LEP14810
      L33=1./(H(3,3)-U13*L31-U23*L32)                                   LEP14820
      U24=(H(2,4)-L21*U14)*L22                                          LEP14830
      U25=(H(2,5)-L21*U15)*L22                                          LEP14840
      L41=H(4,1)                                                        LEP14850
      L42=H(4,2)-L41*U12                                                LEP14860
      L43=H(4,3)-L41*U13-L42*U23                                        LEP14870
      U34=(H(3,4)-L31*U14-L32*U24)*L33                                  LEP14880
      L44=1./(H(4,4)-U14*L41-U24*L42-U34*L43)                           LEP14890
      U35=(H(3,5)-L31*U15-L32*U25)*L33                                  LEP14900
      L51=H(5,1)                                                        LEP14910
      L52=H(5,2)-L51*U12                                                LEP14920
      L53=H(5,3)-L51*U13-L52*U23                                        LEP14930
      L54=H(5,4)-L51*U14-L52*U24-L53*U34                                LEP14940
      U45=(H(4,5)-L41*U15-L42*U25-L43*U35)*L44                          LEP14950
      L55=1./(H(5,5)-L51*U15-L52*U25-L53*U35-L54*U45)                   LEP14960
C     COMPUTE LITTLE R#S                                                LEP14970
      D1=L11*F(I,1)                                                     LEP14980
      D2=L22*(F(I,2)-L21*D1)                                            LEP14990
      D3=L33*(F(I,3)-L31*D1-L32*D2)                                     LEP15000
      D4=L44*(F(I,4)-L41*D1-L42*D2-L43*D3)                              LEP15010
      D5=L55*(F(I,5)-L51*D1-L52*D2-L53*D3-L54*D4)                       LEP15020
C     COMPUTE BIG R#S                                                   LEP15030
      F(I,5)=D5                                                         LEP15040
      F(I,4)=D4-U45*D5                                                  LEP15050
      F(I,3)=D3-U34*F(I,4)-U35*D5                                       LEP15060
      F(I,2)=D2-U23*F(I,3)-U24*F(I,4)-U25*D5                            LEP15070
      F(I,1)=D1-U12*F(I,2)-U13*F(I,3)-U14*F(I,4)-U15*D5                 LEP15080
C     COMPUTE C PRIMES                                                  LEP15090
      DO 25 M=1,5                                                       LEP15100
      D1=L11*C(I,1,M)                                                   LEP15110
      D2=L22*(C(I,2,M)-L21*D1)                                          LEP15120
      D3=L33*(C(I,3,M)-L31*D1-L32*D2)                                   LEP15130
      D4=L44*(C(I,4,M)-L41*D1-L42*D2-L43*D3)                            LEP15140
      D5=L55*(C(I,5,M)-L51*D1-L52*D2-L53*D3-L54*D4)                     LEP15150
      B(I,5,M)=D5                                                       LEP15160
      B(I,4,M)=D4-U45*D5                                                LEP15170
      B(I,3,M) = D3-U34*B(I,4,M)-U35*D5                                 LEP15180
      B(I,2,M) = D2-U23*B(I,3,M)-U24*B(I,4,M)-U25*D5                    LEP15190
   25 B(I,1,M) = D1-U12*B(I,2,M)-U13*B(I,3,M)-U14*B(I,4,M)-U15*D5       LEP15200
   30 CONTINUE                                                          LEP15210
      I=IU                                                              LEP15220
      IR=I-1                                                            LEP15230
C      COMPUTE B PRIME*BIG R FOR LAST ROW                               LEP15240
      DO 35 N=1,5                                                       LEP15250
   35 F(I,N)=F(I,N)-A(I,N,1)*F(IR,1)-A(I,N,2)*F(IR,2)-A(I,N,3)*F(IR,3)  LEP15260
     1 -A(I,N,4)*F(IR,4)-A(I,N,5)*F(IR,5)                               LEP15270
C      COMPUTE B PRIME                                                  LEP15280
      DO 40 M=1,5                                                       LEP15290
      DO 40 N=1,5                                                       LEP15300
   40 H(N,M)=B(I,N,M)-A(I,N,1)*B(IR,1,M)-A(I,N,2)*B(IR,2,M)-A(I,N,3)    LEP15310
     1 *B(IR,3,M)-A(I,N,4)*B(IR,4,M)-A(I,N,5)*B(IR,5,M)                 LEP15320
      L11=1./H(1,1)                                                     LEP15330
      L21=H(2,1)                                                        LEP15340
      U12=H(1,2)*L11                                                    LEP15350
      L22=1./(H(2,2)-L21*U12)                                           LEP15360
      U13=H(1,3)*L11                                                    LEP15370
      U14=H(1,4)*L11                                                    LEP15380
      U15=H(1,5)*L11                                                    LEP15390
      L31=H(3,1)                                                        LEP15400
      L32=H(3,2)-L31*U12                                                LEP15410
      U23=(H(2,3)-L21*U13)*L22                                          LEP15420
      L33=1./(H(3,3)-U13*L31-U23*L32)                                   LEP15430
      U24=(H(2,4)-L21*U14)*L22                                          LEP15440
      U25=(H(2,5)-L21*U15)*L22                                          LEP15450
      L41=H(4,1)                                                        LEP15460
      L42=H(4,2)-L41*U12                                                LEP15470
      L43=H(4,3)-L41*U13-L42*U23                                        LEP15480
      U34=(H(3,4)-L31*U14-L32*U24)*L33                                  LEP15490
      L44=1./(H(4,4)-U14*L41-U24*L42-U34*L43)                           LEP15500
      U35=(H(3,5)-L31*U15-L32*U25)*L33                                  LEP15510
      L51=H(5,1)                                                        LEP15520
      L52=H(5,2)-L51*U12                                                LEP15530
      L53=H(5,3)-L51*U13-L52*U23                                        LEP15540
      L54=H(5,4)-L51*U14-L52*U24-L53*U34                                LEP15550
      U45=(H(4,5)-L41*U15-L42*U25-L43*U35)*L44                          LEP15560
      L55=1./(H(5,5)-L51*U15-L52*U25-L53*U35-L54*U45)                   LEP15570
      D1=L11*F(I,1)                                                     LEP15580
      D2=L22*(F(I,2)-L21*D1)                                            LEP15590
      D3=L33*(F(I,3)-L31*D1-L32*D2)                                     LEP15600
      D4=L44*(F(I,4)-L41*D1-L42*D2-L43*D3)                              LEP15610
      D5=L55*(F(I,5)-L51*D1-L52*D2-L53*D3-L54*D4)                       LEP15620
      F(I,5)=D5                                                         LEP15630
      F(I,4)=D4-U45*D5                                                  LEP15640
      F(I,3)=D3-U34*F(I,4)-U35*D5                                       LEP15650
      F(I,2)=D2-U23*F(I,3)-U24*F(I,4)-U25*D5                            LEP15660
      F(I,1)=D1-U12*F(I,2)-U13*F(I,3)-U14*F(I,4)-U15*D5                 LEP15670
      I=IU                                                              LEP15680
   45 I=I-1                                                             LEP15690
      IP=I+1                                                            LEP15700
      DO 50 N=1,5                                                       LEP15710
   50 F(I,N)=F(I,N)-F(IP,1)*B(I,N,1)-F(IP,2)*B(I,N,2)-F(IP,3)*B(I,N,3)- LEP15720
     1 F(IP,4)*B(I,N,4)-F(IP,5)*B(I,N,5)                                LEP15730
      IF (I.GT.IL) GO TO 45                                             LEP15740
      RETURN                                                            LEP15750
      END                                                               LEP15760
*DECK DIFFER                                                            LEP15770
      SUBROUTINE DIFFER(RD,IMIN,IMAX,ISYMIN,ISYMAX)                     LEP15780
*CALL BTRID                                                             LEP15790
      I1=IMIN+1                                                         LEP15800
      I2=IMAX-1                                                         LEP15810
      DO 100 N=1,5                                                      LEP15820
      DO 100 I=I1,I2                                                    LEP15830
  100 F(I,N)=RD*(C(I+1,N,1)-C(I-1,N,1))                                 LEP15840
      IF(ISYMIN.GT.0) GO TO 300                                         LEP15850
      DO 200 N=1,5                                                      LEP15860
  200 F(IMIN,N)=2.0*RD*(C(I1,N,1)-C(IMIN,N,1))                          LEP15870
      GO TO 500                                                         LEP15880
  300 DO 400 N=1,5                                                      LEP15890
  400 F(IMIN,N)=2.0*RD*C(I1,N,1)                                        LEP15900
      F(IMIN,ISYMIN)=0.0                                                LEP15910
  500 IF(ISYMAX.GT.0) GO TO 700                                         LEP15920
      DO 600 N=1,5                                                      LEP15930
  600 F(IMAX,N)=2.0*RD*(C(IMAX,N,1)-C(I2,N,1))                          LEP15940
      RETURN                                                            LEP15950
  700 DO 800 N=1,5                                                      LEP15960
  800 F(IMAX,N)=-2.0*RD*C(I2,N,1)                                       LEP15970
      IF(ISYMAX.LT.6) F(IMAX,ISYMAX)=0.0                                LEP15980
      RETURN                                                            LEP15990
      END                                                               LEP16000
*DECK DJMET                                                             LEP16010
      SUBROUTINE DJMET(J,L,XJ,YJ,ZJ)                                    LEP16020
*CALL BASE                                                              LEP16030
*CALL VARS1                                                             LEP16040
*CALL VARS2                                                             LEP16050
      DX2 = .5/DX1                                                      LEP16060
      FAC=1.0                                                           LEP16070
      JP = J+1                                                          LEP16080
      JR = J-1                                                          LEP16090
      IF(J.NE.1) GO TO 100                                              LEP16100
C     FORWARD DIFFERENCE                                                LEP16110
      JR=J                                                              LEP16120
      FAC=2.0                                                           LEP16130
      GO TO 200                                                         LEP16140
  100 IF(J.NE.JMAX) GO TO 200                                           LEP16150
C     BACKWARD DIFFERENCE                                               LEP16160
      JP=J                                                              LEP16170
      FAC=2.0                                                           LEP16180
  200 XJ = (X(JP)-X(JR))*DX2*FAC                                        LEP16190
      YJ = (Y(L,7,JP)-Y(L,7,JR))*DX2*FAC                                LEP16200
      ZJ = (Z(L,8,JP)-Z(L,8,JR))*DX2*FAC                                LEP16210
      RETURN                                                            LEP16220
      END                                                               LEP16230
*DECK DJMET2                                                            LEP16240
      SUBROUTINE DJMET2(J,L,XJ)                                         LEP16250
*CALL BASE                                                              LEP16260
*CALL VARS1                                                             LEP16270
*CALL VARS2                                                             LEP16280
      DX2 = .5/DX1                                                      LEP16290
      FAC=1.0                                                           LEP16300
      JP = J+1                                                          LEP16310
      JR = J-1                                                          LEP16320
      IF(J.NE.1) GO TO 100                                              LEP16330
C     FORWARD DIFFERENCE                                                LEP16340
      JR=J                                                              LEP16350
      FAC=2.0                                                           LEP16360
      GO TO 200                                                         LEP16370
  100 IF(J.NE.JMAX) GO TO 200                                           LEP16380
C     BACKWARD DIFFERENCE                                               LEP16390
      JP=J                                                              LEP16400
      FAC=2.0                                                           LEP16410
  200 XJ = (X(JP)-X(JR))*DX2*FAC                                        LEP16420
      RETURN                                                            LEP16430
      END                                                               LEP16440
*DECK DKMET                                                             LEP16450
      SUBROUTINE DKMET(J,K,L,XK,YK,ZK)                                  LEP16460
*CALL BASE                                                              LEP16470
*CALL VARS1                                                             LEP16480
*CALL VARS2                                                             LEP16490
C     INTERMEDIATE WALL IN K DIRECTION                                  LEP16500
      IF(KPLANE.EQ.0) GO TO 100                                         LEP16510
      XK=0.0                                                            LEP16520
      YK=1.0                                                            LEP16530
      ZK=0.0                                                            LEP16540
      RETURN                                                            LEP16550
  100 DY2 = .5/DY1                                                      LEP16560
      KP = K+1                                                          LEP16570
      KR = K-1                                                          LEP16580
      IF(KW.LE.0.OR.K.LT.KW.OR.K.GT.KW+1.OR.J.GT.JKW) GO TO 200         LEP16590
      IF(LW.GT.0.AND.L.GT.LW) GO TO 200                                 LEP16600
      IF(K.EQ.KW) GO TO 700                                             LEP16610
      IF(K.EQ.KW+1) GO TO 500                                           LEP16620
  200 IF(K.NE.1) GO TO 600                                              LEP16630
C     TEST FOR INTERMEDIATE WALL NORMAL TO K=1 SURFACE                  LEP16640
      IF(LW) 300,300,450                                                LEP16650
  300 IF(JK1WL.LE.J.AND.J.LE.JK1WU) GO TO 500                           LEP16660
C     SYMMETRY                                                          LEP16670
  400 XK=0.0                                                            LEP16680
      ZK=0.0                                                            LEP16690
      YK=2.0*(Y(L,7,KP)-Y(L,7,K))*DY2                                   LEP16700
      RETURN                                                            LEP16710
C     TEST FOR WALL NORMAL TO K=1 SURFACE                               LEP16720
  450 IF(L-LW) 300,300,400                                              LEP16730
C     FOWARD DIFFERECNE                                                 LEP16740
  500 FAC=2.0                                                           LEP16750
      KR=K                                                              LEP16760
      GO TO 900                                                         LEP16770
  600 IF(K.NE.KMAX) GO TO 800                                           LEP16780
      IF(KMAXBC.LT.3.OR.KMAXBC.GT.4) GO TO 700                          LEP16790
C     SYMMETRY                                                          LEP16800
      XK=0.0                                                            LEP16810
      YK=0.0                                                            LEP16820
      ZK=0.0                                                            LEP16830
      IF(KMAXBC.EQ.3) YK=2.0*(Y(L,7,K)-Y(L,7,KR))*DY2                   LEP16840
      IF(KMAXBC.EQ.4) ZK=2.0*(Z(L,8,K)-Z(L,8,KR))*DY2                   LEP16850
      RETURN                                                            LEP16860
C     BACKWARD DIFFERENCE                                               LEP16870
  700 KP=K                                                              LEP16880
      FAC=2.0                                                           LEP16890
      GO TO 900                                                         LEP16900
C     CENTRAL DIFFERENCE                                                LEP16910
  800 FAC=1.0                                                           LEP16920
  900 XK=0.                                                             LEP16930
      YK=(Y(L,7,KP)-Y(L,7,KR))*DY2*FAC                                  LEP16940
      ZK=(Z(L,8,KP)-Z(L,8,KR))*DY2*FAC                                  LEP16950
      RETURN                                                            LEP16960
      END                                                               LEP16970
*DECK DLMET                                                             LEP16980
      SUBROUTINE DLMET(J,K,L,XL,YL,ZL)                                  LEP16990
*CALL BASE                                                              LEP17000
*CALL VARS1                                                             LEP17010
*CALL VARS2                                                             LEP17020
      COMMON/AXISYM/LAXIS                                               LEP17030
C     INTERMEDIATE WALL IN L DIRECTION                                  LEP17040
      DZ2 = .5/DZ1                                                      LEP17050
      LP = L+1                                                          LEP17060
      LR = L-1                                                          LEP17070
      IF(LW.LE.0.OR.L.LT.LW.OR.L.GT.LW+1.OR.J.GT.JLW) GO TO 100         LEP17080
      IF(KW.GT.0.AND.K.GT.KW) GO TO 100                                 LEP17090
      IF(L.EQ.LW) GO TO 700                                             LEP17100
      IF(L.EQ.LW+1) GO TO 500                                           LEP17110
  100 IF(L.NE.1) GO TO 600                                              LEP17120
C     AXIS OF SYMMETRY                                                  LEP17130
      IF(LAXIS.NE.1) GO TO 150                                          LEP17140
      XL=0.0                                                            LEP17150
      YL=Y(LP,7,K)-Y(L,7,K)                                             LEP17160
      ZL=Z(LP,8,K)-Z(L,8,K)                                             LEP17170
      GO TO 999                                                         LEP17180
C     TEST FOR INTERMEDIATE WALL NORMAL TO L=1 SURFACE                  LEP17190
  150 IF(KW) 200,200,400                                                LEP17200
C     TEST FOR WALL AT L=1                                              LEP17210
  200 IF(JL1WL.LE.J.AND.J.LE.JL1WU) GO TO 500                           LEP17220
C     SYMMETRY                                                          LEP17230
  300 XL=0.0                                                            LEP17240
      YL=0.0                                                            LEP17250
      ZL=2.0*(Z(LP,8,K)-Z(L,8,K))*DZ2                                   LEP17260
      GO TO 999                                                         LEP17270
C     TEST FOR WALL AT L=1                                              LEP17280
  400 IF(K-KW) 200,200,300                                              LEP17290
C     FORWARD DIFFERENCE                                                LEP17300
  500 LR=L                                                              LEP17310
      FAC=2.0                                                           LEP17320
      GO TO 900                                                         LEP17330
  600 IF(L.NE.LMAX) GO TO 800                                           LEP17340
      IF(LMAXBC.LT.3.OR.LMAXBC.GT.4) GO TO 700                          LEP17350
C     SYMMETRY                                                          LEP17360
      XL=0.0                                                            LEP17370
      YL=0.0                                                            LEP17380
      ZL=0.0                                                            LEP17390
      IF(LMAXBC.EQ.3) YL=2.0*(Y(L,7,K)-Y(LR,7,K))*DZ2                   LEP17400
      IF(LMAXBC.EQ.4) ZL=2.0*(Z(L,8,K)-Z(LR,8,K))*DZ2                   LEP17410
      GO TO 999                                                         LEP17420
C     BACKWARD DIFFERENCE                                               LEP17430
  700 LP=L                                                              LEP17440
      FAC=2.0                                                           LEP17450
      GO TO 900                                                         LEP17460
C     CENTRAL DIFFERENCE                                                LEP17470
  800 FAC=1.0                                                           LEP17480
  900 XL=0.                                                             LEP17490
      YL=(Y(LP,7,K)-Y(LR,7,K))*DZ2*FAC                                  LEP17500
      ZL=(Z(LP,8,K)-Z(LR,8,K))*DZ2*FAC                                  LEP17510
  999 RETURN                                                            LEP17520
      END                                                               LEP17530
*DECK DYZ                                                               LEP17540
      SUBROUTINE DYZ                                                    LEP17550
*CALL BTRID                                                             LEP17560
*CALL RHSBCC                                                            LEP17570
      I1=I+1                                                            LEP17580
      IF(I.EQ.3) I1=1                                                   LEP17590
      DO 100 L=1,LORKMX                                                 LEP17600
      DO 100 N=1,5                                                      LEP17610
  100 F(L,N)=C(L,N,I)-C(L,N,I1)                                         LEP17620
      RETURN                                                            LEP17630
      END                                                               LEP17640
*DECK DYZBCX                                                            LEP17650
      SUBROUTINE DYZBCX(ISW)                                            LEP17660
*CALL BASE                                                              LEP17670
*CALL RHSBCC                                                            LEP17680
*CALL BTRID                                                             LEP17690
C     EVALUATE VISCOUS CROSS TERMS AT UPPER BOUNDARY KMAX(LMAX WHEN ISW=LEP17700
C     OR AT THE INNER SURFACE K=KW (L=LW) OF AN INTERNAL WALL WHEN ISW=2LEP17710
      I1=I-1                                                            LEP17720
      IF(I.EQ.1) I1=3                                                   LEP17730
      L2=LORKMX                                                         LEP17740
      IF(ISW.EQ.2) GO TO 300                                            LEP17750
      IF(KLMXBC.EQ.0) RETURN                                            LEP17760
C     BOUNDARY AT K=KMAX(L=LMAX)                                        LEP17770
C     WALL B.C.(LKMXBC=1),                                              LEP17780
C     FREE STREAM BC(KLMXBC=2) OR OUTFLOW BC(KLMXBC=5)                  LEP17790
   80 DO 90 L=1,L2                                                      LEP17800
   90 F(L,1)=0.0                                                        LEP17810
      DO 100 N=2,5                                                      LEP17820
      DO 100 L=1,L2                                                     LEP17830
  100 F(L,N)=2.0*(C(L,N,I)-C(L,N,I1))                                   LEP17840
      IF(ISW.EQ.2) RETURN                                               LEP17850
      IF(KLMXBC.EQ.3.OR.KLMXBC.EQ.4) GO TO 500                          LEP17860
      RETURN                                                            LEP17870
C     INTERNAL WALL AT K=KW (L=LW)                                      LEP17880
  300 IF(J.GT.JKLW) RETURN                                              LEP17890
      IF(LORKW.GT.0) L2=LORKW                                           LEP17900
      GO TO 80                                                          LEP17910
C     SYMMETRY B.C. FOR VELOCITY COMPONENT NORMAL TO UPPER BOUNDARY     LEP17920
  500 DO 600 L=1,LORKMX                                                 LEP17930
  600 F(L,KLMXBC)=0.0                                                   LEP17940
      RETURN                                                            LEP17950
      END                                                               LEP17960
*DECK DYZBC1                                                            LEP17970
      SUBROUTINE DYZBC1(ISW)                                            LEP17980
*CALL BASE                                                              LEP17990
*CALL RHSBCC                                                            LEP18000
*CALL BTRID                                                             LEP18010
C     EVALUATE VISCOUS CROSS TERMS AT A LOWER BDRY K=1 (L=1) WHEN ISW=1,LEP18020
C     OR AT THE OUTER SURFACE K=KW+1 (L=LW+1) OF AN INTERNAL WALL       LEP18030
C     WHEN ISW=2                                                        LEP18040
      L1=1                                                              LEP18050
      IF(ISW.EQ.2) GO TO 100                                            LEP18060
      IF(KL1BC.EQ.0) RETURN                                             LEP18070
C     BOUNDARY AT K=1(L=1)                                              LEP18080
      IF(J.LT.JKL1WL.OR.J.GT.JKL1WU) GO TO 300                          LEP18090
  100 L2=LORKMX                                                         LEP18100
      IF(LORKW.GT.0) L2=LORKW+ISW-1                                     LEP18110
C     INTERNAL WALL                                                     LEP18120
      IF(ISW.EQ.1) GO TO 150                                            LEP18130
      IF(J-JKLW) 150,150,110                                            LEP18140
  110 IF(L2.EQ.LORKMX) RETURN                                           LEP18150
      IF(J.GT.JLKW) RETURN                                              LEP18160
      L1=L2-1                                                           LEP18170
C     ADIABATIC WALL BC ON ENERGY EQUATION                              LEP18180
  150 I1=I-1                                                            LEP18190
      IF(I.EQ.1) I1=3                                                   LEP18200
      DO 200 L=1,L2                                                     LEP18210
      DO 190 N=1,4                                                      LEP18220
  190 F(L,N)=0.                                                         LEP18230
  200 F(L,5)=2.0*(C(L,5,I)-C(L,5,I1))                                   LEP18240
      IF(ISW.EQ.2) RETURN                                               LEP18250
  250 IF(L2.EQ.LORKMX) RETURN                                           LEP18260
      L1=L2+1                                                           LEP18270
C     SYM BC AT KL=1.AND.J.LT.JKL1WL.OR.J.GT.JKL1WU.AND.LK.GT.LORKW     LEP18280
  300 DO 500 L=L1,LORKMX                                                LEP18290
      DO 400 N=1,5                                                      LEP18300
  400 F(L,N)=2.0*(C(L,N,2)-C(L,N,1))                                    LEP18310
  500 F(L,IW+2)=0.0                                                     LEP18320
      RETURN                                                            LEP18330
      END                                                               LEP18340
*DECK DZY                                                               LEP18350
      SUBROUTINE DZY(KORL)                                              LEP18360
*CALL RHSBCC                                                            LEP18370
*CALL BASE                                                              LEP18380
*CALL VARS1                                                             LEP18390
*CALL BTRID                                                             LEP18400
*CALL VISC                                                              LEP18410
*CALL VARS2                                                             LEP18420
      DIMENSION SS(13,1),T(13)                                          LEP18430
      EQUIVALENCE(SS,A),(T(1),T1,B(1,5,1)),(T(2),T2),(T(3),T3),(T(4),T4)LEP18440
     2,(T(5),T5),(T(6),T6),(T(7),T7),(T(8),T8),(T(9),T9),(T(10),T10)    LEP18450
     3,(T(11),T11),(T(12),T12),(T(13),T13)                              LEP18460
C     VISCOUS STRESSES( INNER FIRST DERIVATIVES) FOR VISCOUS CROSS      LEP18470
C     TERMS IN A K,L PLANE                                              LEP18480
      IF(IW.EQ.2) GO TO 300                                             LEP18490
      K=KORL                                                            LEP18500
      CALL ZZM(J,K,1,LMAX)                                              LEP18510
      DO 100 L=1,LMAX                                                   LEP18520
      CALL YYM(J,L,K,K)                                                 LEP18530
      DO 100 N=1,4                                                      LEP18540
  100 XX(L,N)=YY(K,N)                                                   LEP18550
      DO 200 L=1,LMAX                                                   LEP18560
      DO 200 N=1,4                                                      LEP18570
  200 YY(L,N)=XX(L,N)                                                   LEP18580
      GO TO 600                                                         LEP18590
  300 L=KORL                                                            LEP18600
      CALL YYM(J,L,1,KMAX)                                              LEP18610
      DO 400 K=1,KMAX                                                   LEP18620
      CALL ZZM(J,K,L,L)                                                 LEP18630
      DO 400 N=1,4                                                      LEP18640
  400 XX(K,N)=ZZ(L,N)                                                   LEP18650
      DO 500 K=1,KMAX                                                   LEP18660
      DO 500 N=1,4                                                      LEP18670
      ZZ(K,N)=YY(K,N)                                                   LEP18680
  500 YY(K,N)=XX(K,N)                                                   LEP18690
  600 K=KORL                                                            LEP18700
      QW=0.0                                                            LEP18710
      DO 800 L=1,LORKMX                                                 LEP18720
      LLL=L                                                             LEP18730
      KKK=K                                                             LEP18740
      IF(IW.EQ.2) LLL=K                                                 LEP18750
      IF(IW.EQ.2) KKK=L                                                 LEP18760
      RA = 1./Q(LLL,1,KKK)                                              LEP18770
      Q2 = (Q(LLL,2,KKK)**2 + Q(LLL,3,KKK)**2 + Q(LLL,4,KKK)**2)*RA     LEP18780
      TT= GD*(Q(LLL,5,KKK) - 0.5*Q2)*RA                                 LEP18790
      CALL VISCOF(TT,RMUE)                                              LEP18800
      RMUE=TT                                                           LEP18810
      VNU = RMUE+TURMU(LLL,6,KKK)                                       LEP18820
      GKAP = RMUE+PRTR*TURMU(LLL,6,KKK)                                 LEP18830
      RJ = 1./Q6(LLL,KKK)                                               LEP18840
      G1=RJ*VNU                                                         LEP18850
      DO 700 N=1,3                                                      LEP18860
      G2=YY(L,N)*G1                                                     LEP18870
      T(N)=ZZ(L,1)*G2                                                   LEP18880
      T(N+3)=ZZ(L,2)*G2                                                 LEP18890
  700 T(N+6)=ZZ(L,3)*G2                                                 LEP18900
      U(L) = Q(LLL,2,KKK)*RA                                            LEP18910
      V(L) = Q(LLL,3,KKK)*RA                                            LEP18920
      W(L) = Q(LLL,4,KKK)*RA                                            LEP18930
      E(L) = Q(LLL,5,KKK)*RA-.5*(U(L)**2+V(L)**2+W(L)**2)               LEP18940
      SS(1,L)=T1+T5+T9                                                  LEP18950
      SS(2,L)=SS(1,L)+T1/3.0                                            LEP18960
      SS(3,L)=T2-2./3.*T4                                               LEP18970
      SS(4,L)=T3-2./3.*T7                                               LEP18980
      SS(5,L)=SS(1,L)+T5/3.0                                            LEP18990
      SS(6,L)=T4-2./3.*T2                                               LEP19000
      SS(7,L)=T6-2./3.*T8                                               LEP19010
      SS(8,L)=SS(1,L)+T9/3.                                             LEP19020
      SS(9,L)=T7-2./3.*T3                                               LEP19030
      SS(10,L)=T8-2./3.*T6                                              LEP19040
      SS(11,L)=SS(6,L)*V(L)+SS(9,L)*W(L)                                LEP19050
      SS(12,L)=SS(3,L)*U(L)+SS(10,L)*W(L)                               LEP19060
      SS(13,L)=SS(4,L)*U(L)+SS(7,L)*V(L)                                LEP19070
      SS(1,L)=GKPR*GKAP*SS(1,L)/VNU                                     LEP19080
  800 CONTINUE                                                          LEP19090
      I=I+1                                                             LEP19100
      IF(I.EQ.4) I=1                                                    LEP19110
C     LATERAL LIMIT OF INTERNAL AND LOWER WALLS                         LEP19120
      KLWP=KORLW                                                        LEP19130
      IF(KORLW.EQ.0) KLWP=KORLMX                                        LEP19140
      DO 1000 L=1,LORKMX                                                LEP19150
C     CENTRAL DIFFERENCES AT INTERIOR POINTS                            LEP19160
      NDIFAC=1                                                          LEP19170
      L1=L+1                                                            LEP19180
      L2=L-1                                                            LEP19190
C     ONE-SIDED DIFFERENCES AT BOUNDARY POINTS                          LEP19200
C     LOWER BOUNDARY L (K) =1                                           LEP19210
      IF(L.NE.1) GO TO 801                                              LEP19220
      L2=L                                                              LEP19230
      NDIFAC=2                                                          LEP19240
      GO TO 890                                                         LEP19250
C     UPPER BOUNDARY LMAX (KMAX)                                        LEP19260
  801 IF(L.NE.LORKMX) GO TO 805                                         LEP19270
      L1=L                                                              LEP19280
      NDIFAC=2                                                          LEP19290
      GO TO 890                                                         LEP19300
C     INTERNAL WALLS                                                    LEP19310
C     TEST FOR INTERNAL WALL NORMAL TO L (K) DIRECTION THAT WOULD DISRUPLEP19320
C     CENTRAL DIFFERENCES IN THAT DIRECTION                             LEP19330
  805 IF(LORKW.EQ.0) GO TO 890                                          LEP19340
      LKWP=LORKW+1                                                      LEP19350
      IF(L.NE.LORKW .AND.  L.NE.LKWP) GO TO 890                         LEP19360
C     TEST FOR INTERNAL WALL PARALLEL TO L (K) DIRECTION                LEP19370
      IF(KORLW) 850,850,810                                             LEP19380
C     ONE-SIDED DIFFERENCES AT UPPER EDGE OF THE INTERNAL WALL          LEP19390
C     PARALLEL TO L (K) DIRECTION                                       LEP19400
  810 IF(L.NE.LKWP) GO TO 850                                           LEP19410
      IF(J.GT.JKLW .OR. K.NE.KORLW .OR. K.NE.KORLW+1) GO TO 850         LEP19420
      L2=L                                                              LEP19430
      NDIFAC=2                                                          LEP19440
      GO TO 890                                                         LEP19450
C     ONE-SIDED DIFFERENCES ON FACES OF THE INTERNAL WALL NORMAL TO THE LEP19460
C     L (K) DIRECTION                                                   LEP19470
  850 IF(K.GT.KLWP.OR. J.GT.JLKW) GO TO 890                             LEP19480
      IF(L.EQ.LORKW) L1=L                                               LEP19490
      IF(L.EQ.LKWP) L2=L                                                LEP19500
      NDIFAC=2                                                          LEP19510
  890 CONTINUE                                                          LEP19520
      DO 900 N=1,13                                                     LEP19530
  900 T(N)=SS(N,L)                                                      LEP19540
C     DERIVATIVES                                                       LEP19550
      DU = U(L1)-U(L2)                                                  LEP19560
      DV = V(L1)-V(L2)                                                  LEP19570
      DW = W(L1)-W(L2)                                                  LEP19580
      DEI = E(L1)-E(L2)                                                 LEP19590
      DU2=(U(L1)**2-U(L2)**2)*0.5                                       LEP19600
      DV2=(V(L1)**2-V(L2)**2)*0.5                                       LEP19610
      DW2=(W(L1)**2-W(L2)**2)*0.5                                       LEP19620
C     BOUNDARY POINT DERIVATIVES                                        LEP19630
      IF(L.NE.1) GO TO 930                                              LEP19640
C     LOWER BOUNDARY L (K)=1                                            LEP19650
C     TEST B.C. OPTIONS                                                 LEP19660
      IF(LK1BC) 980,980,910                                             LEP19670
C      TEST FOR LOWER WALL                                              LEP19680
  910 IF(K.LE.KLWP .AND. J.GE.JLK1WL .AND. J.LE.JLK1WU) GO TO 990       LEP19690
C     SYMMETRY CONDITIONS OUTSIDE WALL REGION                           LEP19700
      IF(IW-1) 915,915,920                                              LEP19710
C     SYMMETRY PLANE Z=CONSTANT                                         LEP19720
  915 DWFAC=1.0                                                         LEP19730
      DVFAC=0.0                                                         LEP19740
      GO TO 970                                                         LEP19750
C     SYMMETRY PLANE Y=CONSTANT                                         LEP19760
  920 DWFAC=0.0                                                         LEP19770
      DVFAC=1.                                                          LEP19780
      GO TO 970                                                         LEP19790
C     UPPER BOUNDARY LMAX (KMAX)                                        LEP19800
  930 IF(L.NE.LORKMX) GO TO 990                                         LEP19810
C     TEST B.C. OPTIONS                                                 LEP19820
      GO TO (980,990,980,920,915,980),LKMXBC+1                          LEP19830
C     INTERNAL WALLS ARE TAKEN CARE OF BY ONE-SIDED DIFFERENCES AS      LEP19840
C     SET UP PREVIOUSLY                                                 LEP19850
C     SYMMETRY CONDITIONS ON DERIVATIVES                                LEP19860
  970 DU=0.                                                             LEP19870
      DU2=0.                                                            LEP19880
      DV2=0.                                                            LEP19890
      DW2=0.                                                            LEP19900
      DEI=0.                                                            LEP19910
      DV=DV*DVFAC                                                       LEP19920
      DW=DW*DWFAC                                                       LEP19930
      GO TO 990                                                         LEP19940
C     SET VISCOUS STRESSES TO ZERO                                      LEP19950
  980 DO 985 N=1,5                                                      LEP19960
      C(L,N,I)=0.0                                                      LEP19970
  985 CONTINUE                                                          LEP19980
      GO TO 1000                                                        LEP19990
C     CORRECTION FACTOR FOR ONE-SIDED DIFFERENCES                       LEP20000
  990 IF(NDIFAC.NE.2) GO TO 995                                         LEP20010
      DU=DU*2.0                                                         LEP20020
      DV=DV*2.0                                                         LEP20030
      DW=DW*2.0                                                         LEP20040
      DU2=DU2*2.0                                                       LEP20050
      DV2=DV2*2.0                                                       LEP20060
      DW2=DW2*2.0                                                       LEP20070
      DEI=DEI*2.0                                                       LEP20080
  995 CONTINUE                                                          LEP20090
C     COMPUTE VISCOUS STRESSES                                          LEP20100
      C(L,1,I)=0.0                                                      LEP20110
      C(L,2,I)=T2*DU+T3*DV+T4*DW                                        LEP20120
      C(L,3,I)=T6*DU+T5*DV+T7*DW                                        LEP20130
      C(L,4,I)=T9*DU+T10*DV+T8*DW                                       LEP20140
      C(L,5,I)=T1*DEI+T2*DU2+T5*DV2+T8*DW2+T11*DU+T12*DV+T13*DW         LEP20150
 1000 CONTINUE                                                          LEP20160
      RETURN                                                            LEP20170
      END                                                               LEP20180
*DECK DZYBC                                                             LEP20190
      SUBROUTINE DZYBC(K)                                               LEP20200
*CALL RHSBCC                                                            LEP20210
*CALL BTRID                                                             LEP20220
*CALL VISC                                                              LEP20230
      KLWP1=KORLW+1                                                     LEP20240
      IF(KORLW.EQ.0) KLWP1=KORLMX                                       LEP20250
      L=LORKW+1                                                         LEP20260
      IF(J.LE.JLKW.AND.LORKW.GT.0.AND.K.LE.KLWP1) GO TO 200             LEP20270
  100 L=1                                                               LEP20280
      IF(LK1BC.EQ.0) GO TO 500                                          LEP20290
      IF(J.LT.JLK1WL.OR.J.GT.JLK1WU.OR.K.GT.KLWP1) GO TO 300            LEP20300
C     WALL BC FOR JLK1WL.LE.J.LE.JLK1WU FOR L=1(K=1)                    LEP20310
  200 C(L,1,I)=0.0                                                      LEP20320
      C(L,2,I)=2.0*(U(L+1)-U(L))                                        LEP20330
      C(L,3,I)=2.0*(V(L+1)-V(L))                                        LEP20340
      C(L,4,I)=2.0*(W(L+1)-W(L))                                        LEP20350
      C(L,5,I)=2.0*(E(L+1)-E(L))                                        LEP20360
      IF(L-1) 500,500,100                                               LEP20370
C     SYMMETRY BC FOR J.LT.JLK1WL.OR.J.GT.JLK1WU FOR L=1(K=1)           LEP20380
  300 DO 400 N=1,5                                                      LEP20390
  400 C(1,N,I)=0.0                                                      LEP20400
      IF(IW.EQ.1) C(1,4,I)=2.0*(W(2)-W(1))                              LEP20410
      IF(IW.EQ.2) C(1,3,I)=2.0*(V(2)-V(1))                              LEP20420
  500 L=LORKW                                                           LEP20430
      IF(J.LE.JLKW.AND.LORKW.GT.0.AND.K.LE.KLWP1) GO TO 700             LEP20440
  600 IF(LKMXBC.EQ.0.OR.LKMXBC.EQ.2.OR.LKMXBC.EQ.5) RETURN              LEP20450
      L=LORKMX                                                          LEP20460
      IF(LKMXBC.NE.1) GO TO 800                                         LEP20470
C     WALL BC FOR L=LMAX(K=KMAX)                                        LEP20480
  700 C(L,1,I)=0.0                                                      LEP20490
      C(L,2,I)=2.0*(U(L)-U(L-1))                                        LEP20500
      C(L,3,I)=2.0*(V(L)-V(L-1))                                        LEP20510
      C(L,4,I)=2.0*(W(L)-W(L-1))                                        LEP20520
      C(L,5,I)=2.0*(E(L)-E(L-1))                                        LEP20530
      IF(L.LT.LORKMX) GO TO 600                                         LEP20540
      RETURN                                                            LEP20550
  800 DO 900 N=1,5                                                      LEP20560
  900 C(L,N,I)=0.0                                                      LEP20570
C     REFLECTIVE SYM BC WHEN LMAX(KMAX) A PLANE PARALLEL TO XY(YZ) PLANELEP20580
      IF(LKMXBC.EQ.3) C(L,3,I)=2.0*(V(L)-V(L-1))                        LEP20590
C     REFLECTIVE SYM BC WHEN LMAX(KMAX) A PLANE PARALLEL TO XZ(XY) PLANELEP20600
      IF(LKMXBC.EQ.4) C(L,4,I)=2.0*(W(L)-W(L-1))                        LEP20610
      RETURN                                                            LEP20620
      END                                                               LEP20630
*DECK DZYDYZ                                                            LEP20640
      SUBROUTINE DZYDYZ(IWW,JJ)                                         LEP20650
*CALL BASE                                                              LEP20660
*CALL VARS1                                                             LEP20670
*CALL BTRID                                                             LEP20680
*CALL RHSBCC                                                            LEP20690
*CALL VARS2                                                             LEP20700
C     VISCOUS RIGHT HAND SIDE TERMS THAT CONTAIN CROSS DERIVATIVES      LEP20710
C     IN THE K,L OR L,K DIRECTIONS                                      LEP20720
      DRE = HD/(RE*DZ1*DY1*2.0)                                         LEP20730
      IW=IWW                                                            LEP20740
      CALL SW                                                           LEP20750
      I=0                                                               LEP20760
      KLXP=KORLMX+1                                                     LEP20770
      J=JJ                                                              LEP20780
      KLWT=KORLW                                                        LEP20790
      IF(KORLW.EQ.0) KLWT=-5                                            LEP20800
      DO 300 K=1,KLXP                                                   LEP20810
      IF(K.LT.KLXP) CALL DZY(K)                                         LEP20820
      IF(K.EQ.1) GO TO 300                                              LEP20830
      IF(K.EQ.2) CALL DYZBC1(1)                                         LEP20840
      IF(K.GT.2.AND.K.LT.KLXP) CALL DYZ                                 LEP20850
      IF(K.EQ.KLWT+2) CALL DYZBC1(2)                                    LEP20860
      IF(K.EQ.KLXP) CALL DYZBCX(1)                                      LEP20870
      IF(K.EQ.KLWT+1) CALL DYZBCX(2)                                    LEP20880
      DO 200 L=1,LORKMX                                                 LEP20890
      LLL=L                                                             LEP20900
      KKK=K-1                                                           LEP20910
      IF(IW.EQ.2) KKK=L                                                 LEP20920
      IF(IW.EQ.2) LLL=K-1                                               LEP20930
      DO 200 N = 2,5                                                    LEP20940
  200 S(LLL,N+8,KKK) = S(LLL,N+8,KKK)+F(L,N)*DRE                        LEP20950
  300 CONTINUE                                                          LEP20960
      RETURN                                                            LEP20970
      END                                                               LEP20980
*DECK DZZDYY                                                            LEP20990
      SUBROUTINE DZZDYY(IWW,JJ)                                         LEP21000
*CALL BASE                                                              LEP21010
*CALL VARS1                                                             LEP21020
*CALL BTRID                                                             LEP21030
*CALL RHSBCC                                                            LEP21040
*CALL VISC                                                              LEP21050
*CALL VARS2                                                             LEP21060
C     VISCOUS RIGHT HAND SIDE TERMS THAT CONTAIN ONLY UNIDIRECTIONAL    LEP21070
C     DERIVATIVES IN EITHER THE K OR L DIRECTION.                       LEP21080
      IW=IWW                                                            LEP21090
      CALL SW                                                           LEP21100
      LKWR=LORKW+1                                                      LEP21110
      KLWR=KORLW+1                                                      LEP21120
      GKPR = GAMMA/PR                                                   LEP21130
      PRTR = PR/0.9                                                     LEP21140
      DRE = HD/(RE*DZORDY**2)                                           LEP21150
      J=JJ                                                              LEP21160
      DO 2000 K = KLORLL,KUORLU                                         LEP21170
      INTWAL=0                                                          LEP21180
      IF(LORKW.GT.0.AND.J.LE.JLKW) INTWAL=1                             LEP21190
      IF(KORLW.GT.0.AND.K.GE.KLWR) INTWAL=0                             LEP21200
      IF(IW.EQ.2) GO TO 700                                             LEP21210
      CALL ZZM(J,K,1,LMAX)                                              LEP21220
      GO TO 900                                                         LEP21230
  700 CALL YYM(J,K,1,KMAX)                                              LEP21240
      DO 800 N=1,4                                                      LEP21250
      DO 800 L=1,KMAX                                                   LEP21260
  800 ZZ(L,N)=YY(L,N)                                                   LEP21270
C     SPECIFY BOUNDARY CONDITION ON DIMENSIONLESS WALL HEAT TRANS-      LEP21280
C   FER RATE QW, NORMALIZED BY RHOINF*CINF**3.                          LEP21290
  900 QW=0.0                                                            LEP21300
      QW=QW*SQRT(ZZ(1,1)**2 + ZZ(1,2)**2 + ZZ(1,3)**2)                  LEP21310
      DO 1000 L = 1,LORKMX                                              LEP21320
      LLL=L                                                             LEP21330
      KKK=K                                                             LEP21340
      IF(IW.EQ.2) LLL=K                                                 LEP21350
      IF(IW.EQ.2) KKK=L                                                 LEP21360
      RA = 1./Q(LLL,1,KKK)                                              LEP21370
      Q2=(Q(LLL,2,KKK)**2 + Q(LLL,3,KKK)**2 + Q(LLL,4,KKK)**2)*RA       LEP21380
      TT = GD*(Q(LLL,5,KKK) - 0.5*Q2)*RA                                LEP21390
      CALL VISCOF(TT,RMUE)                                              LEP21400
      VNU = RMUE+TURMU(LLL,6,KKK)                                       LEP21410
      GKAP = RMUE+PRTR*TURMU(LLL,6,KKK)                                 LEP21420
      RJ = 1./Q6(LLL,KKK)                                               LEP21430
      S0(L) = (ZZ(L,1)**2+ZZ(L,2)**2+ZZ(L,3)**2)*RJ                     LEP21440
      S1(L) = (S0(L)+ZZ(L,1)**2/3.*RJ)*VNU                              LEP21450
      S2(L) = (S0(L)+ZZ(L,2)**2/3.*RJ)*VNU                              LEP21460
      S3(L) = (S0(L)+ZZ(L,3)**2/3.*RJ)*VNU                              LEP21470
      S4(L) = (ZZ(L,1)*ZZ(L,2)/3.*RJ)*VNU                               LEP21480
      S5(L) = (ZZ(L,1)*ZZ(L,3)/3.*RJ)*VNU                               LEP21490
      S6(L) = (ZZ(L,2)*ZZ(L,3)/3.*RJ)*VNU                               LEP21500
      S0(L) = S0(L)*GKPR*GKAP                                           LEP21510
      U(L) = Q(LLL,2,KKK)*RA                                            LEP21520
      V(L) = Q(LLL,3,KKK)*RA                                            LEP21530
      W(L) = Q(LLL,4,KKK)*RA                                            LEP21540
      E(L) = Q(LLL,5,KKK)*RA-.5*(U(L)**2+V(L)**2+W(L)**2)               LEP21550
 1000 CONTINUE                                                          LEP21560
      R2=0.                                                             LEP21570
      R3=0.                                                             LEP21580
      R4=0.                                                             LEP21590
      R5=0.                                                             LEP21600
      DO 1100 L = 1,LMORKM                                              LEP21610
      L1 = L+1                                                          LEP21620
      T1 = S1(L1)+S1(L)                                                 LEP21630
      T2 = S2(L1)+S2(L)                                                 LEP21640
      T3 = S3(L1)+S3(L)                                                 LEP21650
      T4 = S4(L1)+S4(L)                                                 LEP21660
      T5 = S5(L1)+S5(L)                                                 LEP21670
      T6 = S6(L1)+S6(L)                                                 LEP21680
      T16 = S0(L1)+S0(L)                                                LEP21690
      DU = U(L1)-U(L)                                                   LEP21700
      DV = V(L1)-V(L)                                                   LEP21710
      DW = W(L1)-W(L)                                                   LEP21720
      DEI = E(L1)-E(L)                                                  LEP21730
      F2 = T1*DU+T4*DV+T5*DW                                            LEP21740
      F3 = T4*DU+T2*DV+T6*DW                                            LEP21750
      F4 = T5*DU+T6*DV+T3*DW                                            LEP21760
C    CONSERVATIVE DIFFERENCING OF VISCOUS STRESS WORK TERMS IN ENERGY EQLEP21770
      DU2=U(L1)**2-U(L)**2                                              LEP21780
      DV2=V(L1)**2-V(L)**2                                              LEP21790
      DW2=W(L1)**2-W(L)**2                                              LEP21800
      DUV=U(L1)*V(L1)-U(L)*V(L)                                         LEP21810
      DUW=U(L1)*W(L1)-U(L)*W(L)                                         LEP21820
      DVW=V(L1)*W(L1)-V(L)*W(L)                                         LEP21830
      F5=T16*DEI+(T1*DU2+T2*DV2+T3*DW2)*0.5+T4*DUV+T5*DUW+T6*DVW        LEP21840
      F(L,1) = 0.                                                       LEP21850
      F(L,2) = F2-R2                                                    LEP21860
      F(L,3) = F3-R3                                                    LEP21870
      F(L,4) = F4-R4                                                    LEP21880
      F(L,5) = F5-R5                                                    LEP21890
C     VISCOUS TERMS IN ENERGY EQ LOWER SURFACES INTERMEDIATE WALL       LEP21900
      IF(INTWAL.EQ.0) GO TO 1040                                        LEP21910
      IF(L.EQ.LORKW) F(L,5)=-2.0*(R5+DZORDY*RE*QW)                      LEP21920
 1040 R2 = F2                                                           LEP21930
      R3 = F3                                                           LEP21940
      R4 = F4                                                           LEP21950
      R5 = F5                                                           LEP21960
C     VISCOUS TERMS IN ENERGY EQ UPPER SURFACES INTERMEDIATE WALL       LEP21970
      IF(INTWAL.EQ.0) GO TO 1050                                        LEP21980
      IF(L.EQ.LKWR) F(L,5)=2.0*(R5+DZORDY*RE*QW)                        LEP21990
 1050 CONTINUE                                                          LEP22000
      IF(L.GT.1) GO TO 1100                                             LEP22010
      R21=R2                                                            LEP22020
      R31=R3                                                            LEP22030
      R41=R4                                                            LEP22040
      R51=R5                                                            LEP22050
 1100 CONTINUE                                                          LEP22060
C     DEFINE VISCOUS RHS TERMS AT THE LOWER BOUNDARY L=1 FOR            LEP22070
C     LK1BC=1 (EITHER WALL OR SYMMETRY BC)                              LEP22080
      IF(LK1BC.EQ.0) GO TO 1300                                         LEP22090
C     TEST FOR INTERMEDIATE WALL NORMAL TO L=1 SURFACE                  LEP22100
      IF(KORLW) 1110,1110,1120                                          LEP22110
C     TEST FOR WALL AT L=1                                              LEP22120
 1110 IF(JLK1WL.LE.J.AND.J.LE.JLK1WU) GO TO 1150                        LEP22130
C     SYMMETRY                                                          LEP22140
      GO TO 1140                                                        LEP22150
C     TEST FOR WALL AT L=1                                              LEP22160
 1120 IF(K.LE.KORLW.AND.(JLK1WL.LE.J.AND.J.LE.JLK1WU)) GO TO 1150       LEP22170
C     VISCOUS TERMS AT SYMMETRY PLANE PORTION OF LOWER BDY L=1          LEP22180
 1140 F(1,1)=0.0                                                        LEP22190
      F(1,2)=2.0*R21                                                    LEP22200
      F(1,3)=2.0*R31                                                    LEP22210
      F(1,4)=2.0*R41                                                    LEP22220
      F(1,5)=2.0*R51                                                    LEP22230
      F(1,5-IW)=0.0                                                     LEP22240
      GO TO 1300                                                        LEP22250
C     ADIABATIC WALL BC AT WALL PORTION OF LOWER BDY L=1                LEP22260
 1150 DO 1200 N=1,4                                                     LEP22270
 1200 F(1,N)=0.0                                                        LEP22280
      F(1,5)=2.0*(R51+DZORDY*RE*QW)                                     LEP22290
 1300 CONTINUE                                                          LEP22300
C     DEFINE VISCOUS RHS TERMS AT THE UPPER BOUNDARY L=LORKMX           LEP22310
C     FOR LKMXBC=1(WALL),2(FREESTREAM), OR 5(OUTFLOW).                  LEP22320
      DO 1400 N=1,5                                                     LEP22330
 1400 F(LORKMX,N)=0.0                                                   LEP22340
      IF(LKMXBC.EQ.5) GO TO 1500                                        LEP22350
      IF(LKMXBC-3) 1450,1650,1650                                       LEP22360
 1450 IF(LKMXBC-1) 1700,1600,1500                                       LEP22370
 1500 F(LORKMX,2)=-2.0*R2                                               LEP22380
      F(LORKMX,3)=-2.0*R3                                               LEP22390
      F(LORKMX,4)=-2.0*R4                                               LEP22400
      F(LORKMX,5)=-2.0*R5                                               LEP22410
      GO TO 1700                                                        LEP22420
 1600 F(LORKMX,5)=-2.0*(R5+DZORDY*RE*QW)                                LEP22430
      GO TO 1700                                                        LEP22440
C     DEFINE VISCOUS RHS TERMS AT THE UPPER BOUNDARY L=LORKMX WHEN THE  LEP22450
C     LATTER IS A SYMMETRY PLANE(LKMXBC=3 OR 4).                        LEP22460
 1650 F(LORKMX,1)=0.0                                                   LEP22470
      F(LORKMX,2)=-2.0*F2                                               LEP22480
      F(LORKMX,3)=-2.0*F3                                               LEP22490
      F(LORKMX,4)=-2.0*F4                                               LEP22500
      F(LORKMX,5)=-2.0*F5                                               LEP22510
      F(LORKMX,LKMXBC)=0.0                                              LEP22520
 1700 CONTINUE                                                          LEP22530
      DO 1800 L = LLORKL,LUORKU                                         LEP22540
      LLL=L                                                             LEP22550
      KKK=K                                                             LEP22560
      IF(IW.EQ.2) LLL=K                                                 LEP22570
      IF(IW.EQ.2) KKK=L                                                 LEP22580
      DO 1800 N = 1,5                                                   LEP22590
 1800 S(LLL,N+8,KKK) = S(LLL,N+8,KKK)+F(L,N)*DRE                        LEP22600
 2000 CONTINUE                                                          LEP22610
      RETURN                                                            LEP22620
      END                                                               LEP22630
*DECK EIGEN                                                             LEP22640
      SUBROUTINE EIGEN(J)                                               LEP22650
*CALL BASE                                                              LEP22660
*CALL VARS1                                                             LEP22670
*CALL VARS2                                                             LEP22680
C                                                                       LEP22690
C  COMPUTE EIGENVALUES                                                  LEP22700
C                                                                       LEP22710
C  IF CNBR INPUTED GT 0.0 & THEN DT IS SET FOR THAT COURANT NUMBER      LEP22720
C  IF CNBR INPUTED EQ 0.0 &THE INPUTED DT IS USED AND THE MAXIMUM       LEP22730
C  COURANT NUMBER IS FOUND                                              LEP22740
C                                                                       LEP22750
      DO 10 L=LL,LU                                                     LEP22760
      DO 10 K=KAL,KU                                                    LEP22770
      CALL YYM(J,L,K,K)                                                 LEP22780
      CALL ZZM(J,K,L,L)                                                 LEP22790
      RR = 1./Q(L,1,K)                                                  LEP22800
      U = Q(L,2,K)*RR                                                   LEP22810
      V = Q(L,3,K)*RR                                                   LEP22820
      W = Q(L,4,K)*RR                                                   LEP22830
      SNDSP = SQRT(GD*(Q(L,5,K)*RR-.5*(U*U+V*V+W*W)))                   LEP22840
      SIGB = ABS(YY(K,4)+U*YY(K,1)+V*YY(K,2)+W*YY(K,3))+SNDSP*SQRT(     LEP22850
     1  YY(K,1)**2+YY(K,2)**2+YY(K,3)**2)                               LEP22860
      SIGC = ABS(ZZ(L,4)+U*ZZ(L,1)+V*ZZ(L,2)+W*ZZ(L,3))+SNDSP*SQRT(     LEP22870
     1  ZZ(L,1)**2+ZZ(L,2)**2+ZZ(L,3)**2)                               LEP22880
      SIGBC = AMAX1(SIGB,SIGC)                                          LEP22890
      SIGBC=SIGBC/Q6(L,K)                                               LEP22900
      IF (SIGMAX.GE.SIGBC) GO TO 10                                     LEP22910
      JT = J                                                            LEP22920
      KT = K                                                            LEP22930
      LT = L                                                            LEP22940
      SIGMAX = SIGBC                                                    LEP22950
   10 CONTINUE                                                          LEP22960
      IF (SIGMAX.GT.SIGJMX) GO TO 15                                    LEP22970
      SIGMAX=SIGJMX                                                     LEP22980
      JT=JTJ                                                            LEP22990
      KT=KTJ                                                            LEP23000
      LT=LTJ                                                            LEP23010
   15 CONTINUE                                                          LEP23020
      IF (J.NE.JMAX) GO TO 35                                           LEP23030
      DXM = AMIN1(DX1,DY1,DZ1)                                          LEP23040
      IF (CNBR.LE.0.0) GO TO 25                                         LEP23050
      DT = CNBR*DXM/SIGMAX                                              LEP23060
      DTFAC=1.0                                                         LEP23070
      HD = .5*DT                                                        LEP23080
      HDX = HD/DX1                                                      LEP23090
      HDY = HD/DY1                                                      LEP23100
      HDZ = HD/DZ1                                                      LEP23110
      WRITE (6,20)CNBR,JT,KT,LT,DT                                      LEP23120
   20 FORMAT(1H0,3HCN=,E20.10,3X,11H,AT J,K,L =,3I5,3X,25HTHE TIME STEP LEP23130
     1IS RESET TO,E20.10)                                               LEP23140
   25 CONTINUE                                                          LEP23150
      CNBR = DT*SIGMAX/DXM                                              LEP23160
      WRITE (6,30)JT,KT,LT,CNBR,SMU                                     LEP23170
   30 FORMAT(5X,30HJ,K,L, AND MAX COURANT NBR    ,3I5,E14.5,2X,4HSMU=   LEP23180
     1   1PE12.5)                                                       LEP23190
      IGNCAL=IGNCAL-2                                                   LEP23200
   35 CONTINUE                                                          LEP23210
      RETURN                                                            LEP23220
      END                                                               LEP23230
*DECK EIGENJ                                                            LEP23240
      SUBROUTINE EIGENJ(K,L)                                            LEP23250
*CALL BASE                                                              LEP23260
*CALL VARS1                                                             LEP23270
*CALL VARS2                                                             LEP23280
C                                                                       LEP23290
C  COMPUTE EIGENVALUES                                                  LEP23300
C                                                                       LEP23310
C  IF CNBR INPUTED GT 0.0 & THEN DT IS SET FOR THAT COURANT NUMBER      LEP23320
C  IF CNBR INPUTED EQ 0.0 &THE INPUTED DT IS USED AND THE MAXIMUM       LEP23330
C  COURANT NUMBER IS FOUND                                              LEP23340
C                                                                       LEP23350
      XJ4=0.0                                                           LEP23360
      DO 10 J = JB,JMAX                                                 LEP23370
      RR = 1./Q(L,1,J)                                                  LEP23380
      U = Q(L,2,J)*RR                                                   LEP23390
      V = Q(L,3,J)*RR                                                   LEP23400
      W = Q(L,4,J)*RR                                                   LEP23410
      XJ1=DXIDX(L,14,J)                                                 LEP23420
      XJ2=DXIDY(L,15,J)                                                 LEP23430
      XJ3=DXIDZ(L,16,J)                                                 LEP23440
      SNDSP = SQRT(GD*(Q(L,5,J)*RR-.5*(U*U+V*V+W*W)))                   LEP23450
      SIGA=ABS(XJ4+U*XJ1+V*XJ2+W*XJ3)+SNDSP*SQRT(XJ1**2+XJ2**2+XJ3**2)  LEP23460
      SIGA=SIGA/Q6(L,J)                                                 LEP23470
      IF(SIGJMX.GE.SIGA) GO TO 10                                       LEP23480
      JTJ= J                                                            LEP23490
      KTJ= K                                                            LEP23500
      LTJ= L                                                            LEP23510
      SIGJMX = SIGA                                                     LEP23520
   10 CONTINUE                                                          LEP23530
      RETURN                                                            LEP23540
      END                                                               LEP23550
*DECK FILTRX                                                            LEP23560
      SUBROUTINE FILTRX(K,L,J1,J2)                                      LEP23570
*CALL BASE                                                              LEP23580
*CALL VARS1                                                             LEP23590
*CALL BTRID                                                             LEP23600
*CALL VARS2                                                             LEP23610
      DIMENSION E(5,5)                                                  LEP23620
      JA = J1+1                                                         LEP23630
      JBB = J2-1                                                        LEP23640
      XXJ4=0.0                                                          LEP23650
      DO 15 J=J1,J2                                                     LEP23660
      R1 = DXIDX(L,14,J)*HDX                                            LEP23670
      R2 = DXIDY(L,15,J)*HDX                                            LEP23680
      R3 = DXIDZ(L,16,J)*HDX                                            LEP23690
      R4 = XXJ4*HDX                                                     LEP23700
      CALL AMATRX(E,J,L,R1,R2,R3,R4)                                    LEP23710
      DO 10 M=1,5                                                       LEP23720
      DO 10 N=1,5                                                       LEP23730
   10 D(J,N,M) = E(N,M)                                                 LEP23740
   15 CONTINUE                                                          LEP23750
      DO 30 J=JA,JBB                                                    LEP23760
      RJ = Q6(L,J)                                                      LEP23770
      RR = RM *.5*(RJ+Q6(L,J-1))                                        LEP23780
      RF = RM *.5*(RJ+Q6(L,J+1))                                        LEP23790
      DO 25 N=1,5                                                       LEP23800
      DO 20 M=1,5                                                       LEP23810
      A(J,N,M) = -D(J-1,N,M)                                            LEP23820
      B(J,N,M) = 0.0                                                    LEP23830
   20 C(J,N,M) = D(J+1,N,M)                                             LEP23840
      A(J,N,N) = A(J,N,N)-RR                                            LEP23850
      B(J,N,N) = RJ+RF+RR                                               LEP23860
      C(J,N,N) = C(J,N,N)-RF                                            LEP23870
   25 F(J,N) = S(L,N+8,J)                                               LEP23880
   30 CONTINUE                                                          LEP23890
      RETURN                                                            LEP23900
      END                                                               LEP23910
*DECK FILTRY                                                            LEP23920
      SUBROUTINE FILTRY(J,L,K1,K2)                                      LEP23930
*CALL BASE                                                              LEP23940
*CALL VARS1                                                             LEP23950
*CALL BTRID                                                             LEP23960
*CALL VARS2                                                             LEP23970
      DIMENSION E(5,5)                                                  LEP23980
      KA = K1+1                                                         LEP23990
      KB = K2-1                                                         LEP24000
      CALL YYM(J,L,K1,K2)                                               LEP24010
      DO 15 K=K1,K2                                                     LEP24020
      R1 = YY(K,1)*HDY                                                  LEP24030
      R2 = YY(K,2)*HDY                                                  LEP24040
      R3 = YY(K,3)*HDY                                                  LEP24050
      R4 = YY(K,4)*HDY                                                  LEP24060
      CALL AMATRX(E,K,L,R1,R2,R3,R4)                                    LEP24070
      DO 10 M=1,5                                                       LEP24080
      DO 10 N=1,5                                                       LEP24090
   10 D(K,N,M) = E(N,M)                                                 LEP24100
   15 CONTINUE                                                          LEP24110
      DO 30 K=KA,KB                                                     LEP24120
      RJ = Q6(L,K)                                                      LEP24130
      RR = RM * .5*(RJ+Q6(L,K-1))                                       LEP24140
      RF = RM * .5*(RJ+Q6(L,K+1))                                       LEP24150
      DO 25 N=1,5                                                       LEP24160
      DO 20 M=1,5                                                       LEP24170
      A(K,N,M) = -D(K-1,N,M)                                            LEP24180
      B(K,N,M) = 0.0                                                    LEP24190
   20 C(K,N,M) = D(K+1,N,M)                                             LEP24200
      A(K,N,N) = A(K,N,N)-RR                                            LEP24210
      B(K,N,N) = RJ+RF+RR                                               LEP24220
      C(K,N,N) = C(K,N,N)-RF                                            LEP24230
   25 F(K,N) = S(L,N+8,K)                                               LEP24240
   30 CONTINUE                                                          LEP24250
      RETURN                                                            LEP24260
      END                                                               LEP24270
*DECK FILTRZ                                                            LEP24280
      SUBROUTINE FILTRZ(J,K,L1,L2)                                      LEP24290
*CALL BASE                                                              LEP24300
*CALL VARS1                                                             LEP24310
*CALL BTRID                                                             LEP24320
*CALL VARS2                                                             LEP24330
      DIMENSION E(5,5)                                                  LEP24340
      LA = L1+1                                                         LEP24350
      LB = L2-1                                                         LEP24360
      CALL ZZM(J,K,L1,L2)                                               LEP24370
      DO 15 L=L1,L2                                                     LEP24380
      R1 = ZZ(L,1)*HDZ                                                  LEP24390
      R2 = ZZ(L,2)*HDZ                                                  LEP24400
      R3 = ZZ(L,3)*HDZ                                                  LEP24410
      R4 = ZZ(L,4)*HDZ                                                  LEP24420
      CALL AMATRX(E,K,L,R1,R2,R3,R4)                                    LEP24430
      DO 10 M=1,5                                                       LEP24440
      DO 10 N=1,5                                                       LEP24450
   10 D(L,N,M) = E(N,M)                                                 LEP24460
   15 CONTINUE                                                          LEP24470
      DO 30 L=LA,LB                                                     LEP24480
      RJ = Q6(L,K)                                                      LEP24490
      RR = RM *.5*(RJ+Q6(L-1,K))                                        LEP24500
      RF = RM *.5*(RJ+Q6(L+1,K))                                        LEP24510
      DO 25 N=1,5                                                       LEP24520
      DO 20 M=1,5                                                       LEP24530
      A(L,N,M) = -D(L-1,N,M)                                            LEP24540
      B(L,N,M) = 0.0                                                    LEP24550
   20 C(L,N,M) = D(L+1,N,M)                                             LEP24560
      A(L,N,N) = A(L,N,N)-RR                                            LEP24570
      B(L,N,N) = RJ+RF+RR                                               LEP24580
      C(L,N,N) = C(L,N,N)-RF                                            LEP24590
   25 F(L,N) = S(L,N+8,K)                                               LEP24600
   30 CONTINUE                                                          LEP24610
      RETURN                                                            LEP24620
      END                                                               LEP24630
*DECK FLUXVE                                                            LEP24640
      SUBROUTINE FLUXVE(JK,L,R1,R2,R3,R4)                               LEP24650
*CALL BASE                                                              LEP24660
*CALL VARS1                                                             LEP24670
*CALL VARS2                                                             LEP24680
      RR = 1./Q(L,1,JK)                                                 LEP24690
      U = Q(L,2,JK)*RR                                                  LEP24700
      V = Q(L,3,JK)*RR                                                  LEP24710
      W = Q(L,4,JK)*RR                                                  LEP24720
      QS = R4+R1*U+R2*V+R3*W                                            LEP24730
      PP = GAMI*(Q(L,5,JK)-.5*Q(L,1,JK)*(U*U+V*V+W*W))                  LEP24740
      FV(1) = Q(L,1,JK)*QS                                              LEP24750
      FV(2) = Q(L,2,JK)*QS+R1*PP                                        LEP24760
      FV(3) = Q(L,3,JK)*QS+R2*PP                                        LEP24770
      FV(4) = Q(L,4,JK)*QS+R3*PP                                        LEP24780
      FV(5) = (Q(L,5,JK)+PP)*QS-R4*PP                                   LEP24790
      RETURN                                                            LEP24800
      END                                                               LEP24810
*DECK GDINTF                                                            LEP24820
      SUBROUTINE GDINTF(J,K1,K2,L1,L2,NMX,DINTGL)                       LEP24830
C     DOUBLE INTEGRAL OF FHAT OVER ETA(K) AND ZETA(L) BETWEEN           LEP24840
C     LIMITS (K1,K2) AND (L1,L2)                                        LEP24850
*CALL BASE                                                              LEP24860
*CALL VARS1                                                             LEP24870
*CALL BTRID                                                             LEP24880
*CALL VARS2                                                             LEP24890
      DIMENSION DINTGL(5)                                               LEP24900
      DO 20 L=L1,L2                                                     LEP24910
      DO 15 K=K1,K2                                                     LEP24930
C  METRICS XIX,XIY,XIZ                                                  LEP24950
      M=K                                                               LEP24960
      J1=J                                                              LEP24970
      CALL XXM(L,J1,M,M)                                                LEP24980
      CALL FLUXVE(K,L,XX(K,1),XX(K,2),XX(K,3),0.)                       LEP24990
      DO 10 N=1,NMX                                                     LEP25000
   10 A(K,N,1)=FV(N)                                                    LEP25010
   15 CONTINUE                                                          LEP25020
      DO 20 N=1,NMX                                                     LEP25030
      CALL QDRTR(B(L,N,1),A(1,N,1),DY1,K1,K2)                           LEP25040
   20 CONTINUE                                                          LEP25050
      DO 30 N=1,NMX                                                     LEP25060
      CALL QDRTR(ENTGRL,B(1,N,1),DZ1,L1,L2)                             LEP25070
   30 DINTGL(N)=ENTGRL                                                  LEP25080
      RETURN                                                            LEP25090
      END                                                               LEP25100
*DECK DTSW
      SUBROUTINE DTSW(IDT)
*CALL BASE
C     ROUTINE TO CHANGE DT, ETC. TO NEW DT  IDT=1
C           OR TO CHANGE BACK TO OLD DT     IDT=2
      IF(IDT.EQ.2) GO TO 10
      DTOLD=DT
      SMUOLD=SMU
      DT=DT*DTFAC
      SMU=SMU*DTFAC
      IF(SMU.GT.0.8) SMU=0.8
      IF(DT.GT.DTMAX) DT=DTMAX
      GO TO 20
   10 DT=DTOLD
      SMU=SMUOLD
   20 CONTINUE
      HD = .5*DT
      HDX = HD/DX1
      HDY = HD/DY1
      HDZ = HD/DZ1
      RETURN
      END
*DECK GDINTW
      SUBROUTINE GDINTW(IWW,JJ,LORKIN,KORL1,KORL2,ENDL,GFS)
*CALL BASE
*CALL VARS1
*CALL BTRID
*CALL RHSBCC
*CALL VARS2
      DIMENSION GFS(5)
C     DOUBLE INTEGRAL OF TOTAL STRESS OVER A WALL BOUNDARY SURFACE
C     LORK= CONSTANT BETWEEN LIMITS (J1,J2) AND (KORL1,KORL2).
      J=JJ
      GKPR=GAMMA/PR
      IW=IWW
      L=LORKIN
      NDD=1
      CALL SW
      IF(L.EQ.LORKW.OR.L.EQ.LORKMX) NDD=-NDD
      L1=NDD
      K1=0
      IF(IW.EQ.1) GO TO 5
      L1=0
      K1=NDD
    5 CONTINUE
      DO 200 K=KORL1,KORL2
      IF(IW-1) 10,10,20
   10 CONTINUE
      LORK=L
      KORL=K
      CALL ZZM(J,K,L,L)
      GO TO 30
   20 CONTINUE
      LORK=K
      KORL=L
      CALL YYM(J,K,L,L)
      DO 25 N=1,4
   25 ZZ(L,N)=YY(L,N)
   30 RA=1./Q(LORK,1,KORL)
      Q2=(Q(LORK,2,KORL)**2+Q(LORK,3,KORL)**2+Q(LORK,4,KORL)**2)*RA
      T=GD*(Q(LORK,5,KORL)-0.5*Q2)*RA
      CALL VISCOF(T,RMUE)
      VNU=RMUE
      GKAP=RMUE
C     RECONSTRUCT GEOMETRIC JACOBIAN FROM VOLUME-AVERAGED ONE
      Q6L=Q6(LORK,KORL)
      Q6LP=Q6(LORK+L1,KORL+K1)
      RJ=3./(4.*Q6L-Q6LP)
      S0 = (ZZ(L,1)**2+ZZ(L,2)**2+ZZ(L,3)**2)
      C(K,1,1)=SQRT(S0)
      S0=S0*RJ
      S1 = (S0+ZZ(L,1)**2/3.*RJ)*VNU
      S2 = (S0+ZZ(L,2)**2/3.*RJ)*VNU
      S3 = (S0+ZZ(L,3)**2/3.*RJ)*VNU
      S4 = (ZZ(L,1)*ZZ(L,2)/3.*RJ)*VNU
      S5 = (ZZ(L,1)*ZZ(L,3)/3.*RJ)*VNU
      S6 = (ZZ(L,2)*ZZ(L,3)/3.*RJ)*VNU
      R1=1.0/Q(LORK,1,KORL)
      R2=1.0/Q(LORK+L1,1,KORL+K1)
      R3=1.0/Q(LORK+2*L1,1,KORL+2*K1)
      DU=(4.0*Q(LORK+L1,2,KORL+K1)*R2-3.0*Q(LORK,2,KORL)*R1-Q(LORK+2*L1,
     1  2,KORL+2*K1)*R3)/(2.0*DZ1)
      DV=(4.0*Q(LORK+L1,3,KORL+K1)*R2-3.0*Q(LORK,3,KORL)*R1-Q(LORK+2*L1,
     1 3,KORL+2*K1)*R3)/ (2.0*DZ1)
      DW=(4.0*Q(LORK+L1,4,KORL+K1)*R2-3.0*Q(LORK,4,KORL)*R1-Q(LORK+2*L1,
     1 4,KORL+2*K1)*R3)/ (2.0*DZ1)
      E1=(Q(LORK,5,KORL)-0.5*Q2)*RA
      Q2=R2*(Q(LORK+L1,2,KORL+K1)**2+Q(LORK+L1,3,KORL+K1)**2+Q(LORK+L1,4
     1  ,KORL+K1)**2)
      E2=(Q(LORK+L1,5,KORL+K1)-0.5*Q2)*R2
      Q2=R3*(Q(LORK+2*L1,2,KORL+2*K1)**2+Q(LORK+2*L1,3,KORL+2*K1)**2+
     1 Q(LORK+2*L1,4,KORL+2*K1)**2)
      E3=(Q(LORK+2*L1,5,KORL+2*K1)-0.5*Q2)*R3
      DE=(4.0*E2-3.0*E1-E3)/(2.0*DZ1)
      GFS(2)=S1*DU+S4*DV+S5*DW
      GFS(3)=S2*DV+S4*DU+S6*DW
      GFS(4)=S3*DW+S5*DU+S6*DV
      GFS(5)=S0*GKPR*GKAP*DE
      CALL FLUXVE(KORL,LORK,ZZ(L,1),ZZ(L,2),ZZ(L,3),0.)
      DO 100 N=2,5
C     CORRECT FOR DIRECTIONALITY OF DU,DV,DW,DE
      IF(LORKIN.EQ.LORKW.OR.LORKIN.EQ.LORKMX) GFS(N)=-GFS(N)
  100 A(K,N,1)=FV(N)-GFS(N)/RE
  200 CONTINUE
      CALL QDRTR(ENDL,C,DY1,KORL1,KORL2)
      DO 300 N=2,5
      CALL QDRTR(GFS(N),A(1,N,1),DY1,KORL1,KORL2)
  300 CONTINUE
      RETURN
      END
*DECK GLOANT                                                            LEP25880
      SUBROUTINE GLOANT                                                 LEP25890
*CALL BASE                                                              LEP25900
C     CALCULATE AND WRITE GLOBAL PERFORMANCE PARAMETERS.                LEP25910
      CALL QDRTR(AREF,ENTGD,DX1,1,JMAX)                                 LEP25920
      DO 400 N=1,5                                                      LEP25930
      CALL QDRTR(ENTGRL,ENTGD1(1,N),DX1,1,JMAX)                         LEP25940
  400 GF(N)=ENTGRL                                                      LEP25950
C   CHANGE SCALING OF NON-DIMENSIONAL GENERALIZED FORCE VECTOR GF(N)    LEP25960
C   TO REFERENCE VALUES OF INFLOW BOUNDARY MASS FLUX RHOINF*UINF*AREF,  LEP25970
C   DYNAMIC PRESSURE AREF*.5*RHOINF*UINF**2, AND KINETIC ENERGY         LEP25980
C   FLUX AREF*.5*RHOINF*UINF**3.                                        LEP25990
C   REFERENCE AREA NORMALIZED BY SQUARE OF REFERENCE LENGTH.            LEP26000
      AREF=1.0                                                          LEP26010
      FACM=1.0/RMACH                                                    LEP26020
      GF(1)=FACM*GF(1)/AREF                                             LEP26030
      GF(5)=FACM*GF(5)/AREF                                             LEP26040
      FACM=2.0*FACM*FACM/AREF                                           LEP26050
      DO 500 N=2,5                                                      LEP26060
  500 GF(N)=FACM*GF(N)                                                  LEP26070
      WRITE(3) NC,TAU,GF                                                LEP26080
      WRITE(6,600) GF                                                   LEP26090
  600 FORMAT(///4X,67HGENERALIZED FORCES FROM DIRECT INTEGRATION OF WALLLEP26100
     1 SURFACE STRESSES   /1P5E11.4)                                    LEP26110
      RETURN                                                            LEP26120
      END                                                               LEP26130
*DECK GLOBL                                                             LEP26140
      SUBROUTINE GLOBL(JJ)                                              LEP26150
*CALL BASE                                                              LEP26160
*CALL VARS1                                                             LEP26170
*CALL RHSBCC                                                            LEP26180
*CALL BTRID                                                             LEP26190
*CALL GLOB                                                              LEP26200
*CALL VARS2                                                             LEP26210
      DIMENSION DINTGL(5),ENTBL(5)                                      LEP26220
      DATA IFIRST/0/                                                    LEP26230
C   GLOBL PERFORMANCE PARAMETERS FROM INTEGRAL FORM OF STEADY STATE     LEP26240
C   CONSERVATION LAWS.                                                  LEP26250
C   FREESTREAM CONDITIONS ASSUMED AT GRID POINT (J,K,L)=(1,1,LMAX)      LEP26260
      J=JJ                                                              LEP26270
      NMX=5                                                             LEP26280
      IF (IFIRST.EQ.1) GO TO 15                                         LEP26290
      IFIRST=1                                                          LEP26300
      DO 10 IW=1,2                                                      LEP26310
      DO 10 N=1,NMX                                                     LEP26320
      DO 10 IJ=1,JMAX                                                   LEP26330
      ENTB(IJ,N,IW)=0.                                                  LEP26340
   10 CONTINUE                                                          LEP26350
   15 CONTINUE                                                          LEP26360
      IF (J.EQ.1.OR.J.EQ.JMAX) GO TO 20                                 LEP26370
      GO TO 70                                                          LEP26380
C     INTEGRAL OVER OUTFLOW BOUNDARY                                    LEP26390
   20 L1=1                                                              LEP26400
      L2=LMAX                                                           LEP26410
      K1=1                                                              LEP26420
      K2=KMAX                                                           LEP26430
      CALL GDINTF(J,K1,K2,L1,L2,NMX,DINTGL)                             LEP26440
      DO 25 N=1,NMX                                                     LEP26450
   25 GF(N)=DINTGL(N)                                                   LEP26460
C     CORRECT FOR INTERNAL WALL LW.GT.0                                 LEP26470
      IF (LW.EQ.0) GO TO 40                                             LEP26480
      L1=LW                                                             LEP26490
      L2=LW+1                                                           LEP26500
      K1=1                                                              LEP26510
      K2=KMAX                                                           LEP26520
      IF (KW.EQ.0) GO TO 30                                             LEP26530
      K2=KW+1                                                           LEP26540
      IF (J.LE.JLW) GO TO 30                                            LEP26550
      IF (J.GT.JKW) GO TO 40                                            LEP26560
      K1=KW                                                             LEP26570
   30 CALL GDINTF(J,K1,K2,L1,L2,NMX,DINTGL)                             LEP26580
      DO 35 N=1,NMX                                                     LEP26590
   35 GF(N)=GF(N)-DINTGL(N)                                             LEP26600
C     CORRECT FOR INTERNAL WALL KW.GT.0                                 LEP26610
   40 IF (KW.EQ.0) GO TO 52                                             LEP26620
      IF (J.GT.JKW) GO TO 52                                            LEP26630
      K1=KW                                                             LEP26640
      K2=KW+1                                                           LEP26650
      L1=1                                                              LEP26660
      L2=LMAX                                                           LEP26670
      IF (LW.EQ.0) GO TO 45                                             LEP26680
      L2=LW                                                             LEP26690
   45 CALL GDINTF(J,K1,K2,L1,L2,NMX,DINTGL)                             LEP26700
      DO 50 N=1,NMX                                                     LEP26710
   50 GF(N)=GF(N)-DINTGL(N)                                             LEP26720
   52 CONTINUE                                                          LEP26730
      IF (J.NE.JMAX) GO TO 60                                           LEP26740
      DO 55 N=1,NMX                                                     LEP26750
   55 DINJMX(N)=GF(N)                                                   LEP26760
      GO TO 70                                                          LEP26770
   60 DO 65 N=1,NMX                                                     LEP26780
      DINJ1(N)=GF(N)                                                    LEP26790
   65 CONTINUE                                                          LEP26800
   70 CONTINUE                                                          LEP26810
C     INTEGRALS OVER FREESTREAM BOUNDARIES LORKMX WHEN LKMXBC=2 OR 5    LEP26820
      DO 105 IW=1,2                                                     LEP26830
      CALL SW                                                           LEP26840
      L=LORKMX                                                          LEP26850
      IF (LKMXBC.NE.2.AND.LKMXBC.NE.5) GO TO 105                        LEP26860
      DO 95 K=1,KORLMX                                                  LEP26870
      GO TO (75,80),IW                                                  LEP26880
   75 CONTINUE                                                          LEP26890
      CALL ZZM(J,K,LMAX,LMAX)                                           LEP26900
      R1=ZZ(L,1)                                                        LEP26910
      R2=ZZ(L,2)                                                        LEP26920
      R3=ZZ(L,3)                                                        LEP26930
      CALL FLUXVE(K,L,R1,R2,R3,0.)                                      LEP26940
      GO TO 85                                                          LEP26950
   80 CONTINUE                                                          LEP26960
      CALL YYM(J,K,KMAX,KMAX)                                           LEP26970
      R1=YY(L,1)                                                        LEP26980
      R2=YY(L,2)                                                        LEP26990
      R3=YY(L,3)                                                        LEP27000
      CALL FLUXVE(L,K,R1,R2,R3,0.)                                      LEP27010
   85 CONTINUE                                                          LEP27020
      DO 90 N=1,NMX                                                     LEP27030
   90 A(K,N,1)=FV(N)                                                    LEP27040
   95 CONTINUE                                                          LEP27050
      DO 100 N=1,NMX                                                    LEP27060
      CALL QDRTR(ENTB(J,N,IW),A(1,N,1),1.0,1,KORLMX)                    LEP27070
  100 CONTINUE                                                          LEP27080
  105 CONTINUE                                                          LEP27090
C     SET SWITCH FOR WALL SURFACE INTEGRATION                           LEP27100
      IGFSUR=1                                                          LEP27110
      IF(IGFSUR.EQ.0) GO TO 300                                         LEP27120
      DO 150 N=2,5                                                      LEP27130
      ENTB(J,N,1)=0.                                                    LEP27140
      ENTB(J,N,2)=0.                                                    LEP27150
      ENTD(J)=0.                                                        LEP27160
      DINTGL(N)=0.                                                      LEP27170
      DINJ1(N)=0.                                                       LEP27180
  150 DINJMX(N)=0.                                                      LEP27190
C     COMPUTE GF(2) TO GF(5) DIRECTLY FROM WALL SURFACE INTEGRATIONS    LEP27200
      K1=1                                                              LEP27210
      K2=KMAX                                                           LEP27220
      IF(KW.GT.0) K2=KW                                                 LEP27230
      IF(JL1WU.EQ.0) GO TO 170                                          LEP27240
      IF(J.LT.JL1WL.OR.J.GT.JL1WU) GO TO 170                            LEP27250
      IF(L1BC.NE.1) GO TO 170                                           LEP27260
      FAC=1.
      IF(J.EQ.JL1WL) GO TO 152
      IF(J.EQ.JL1WU) GO TO 152
      GO TO 155
  152 IF(J.EQ.1.OR.J.EQ.JMAX) GO TO 155
      FAC=.5
  155 CONTINUE
      CALL GDINTW(1,J,1,K1,K2,ENTDL,ENTBL)                              LEP27270
      ENTD(J)=ENTDL                                                     LEP27280
      DO 160 N=2,5                                                      LEP27290
  160 ENTB(J,N,1)=ENTB(J,N,1)+ENTBL(N)*FAC                              LEP27300
  170 IF(LMAXBC.NE.1) GO TO 180                                         LEP27310
      CALL GDINTW(1,J,LMAX,K1,K2,ENTDL,ENTBL)                           LEP27320
      ENTD(J)=ENTD(J)+ENTDL                                             LEP27330
      DO 175 N=2,5                                                      LEP27340
  175 ENTB(J,N,1)=ENTB(J,N,1)+ENTBL(N)                                  LEP27350
  180 IF(LW.EQ.0) GO TO 220                                             LEP27360
      IF(J.GT.JLW) GO TO 220                                            LEP27370
      FAC=1.
      IF(J.NE.JLW) GO TO 182
      IF(J.EQ.JMAX) GO TO 182
      FAC=.5
  182 CONTINUE
      CALL GDINTW(1,J,LW,K1,K2,ENTDL,ENTBL)                             LEP27380
      ENTD(J)=ENTD(J)+ENTDL                                             LEP27390
      DO 185 N=2,5                                                      LEP27400
  185 ENTB(J,N,1)=ENTB(J,N,1)+ENTBL(N)*FAC                              LEP27410
      IF(K2.EQ.KW) K2=K2+1                                              LEP27420
      CALL GDINTW(1,J,LW+1,K1,K2,ENTDL,ENTBL)                           LEP27430
      ENTD(J)=ENTD(J)+ENTDL                                             LEP27440
      DO 190 N=2,5                                                      LEP27450
  190 ENTB(J,N,1)=ENTB(J,N,1)+ENTBL(N)*FAC                              LEP27460
  220 L1=1                                                              LEP27470
      L2=LMAX                                                           LEP27480
      IF(LW.GT.0) L2=LW                                                 LEP27490
      IF(JK1WU.EQ.0) GO TO 230                                          LEP27500
      IF(J.LT.JK1WL.OR.J.GT.JK1WU) GO TO 230                            LEP27510
      IF(K1BC.NE.1) GO TO 230                                           LEP27520
      FAC=1.
      IF(J.EQ.JK1WL.OR.J.EQ.JK1WU) GO TO 221
      GO TO 222
  221 IF(J.EQ.1.OR.J.EQ.JMAX) GO TO 222
      FAC=.5
  222 CONTINUE
      CALL GDINTW(2,J,1,L1,L2,ENTDL,ENTBL)                              LEP27530
      ENTD(J)=ENTD(J)+ENTDL                                             LEP27540
      DO 225 N=2,5                                                      LEP27550
  225 ENTB(J,N,1)=ENTB(J,N,1)+ENTBL(N)*FAC                              LEP27560
  230 IF(KMAXBC.NE.1) GO TO 240                                         LEP27570
      CALL GDINTW(2,J,KMAX,L1,L2,ENTDL,ENTBL)                           LEP27580
      ENTD(J)=ENTD(J)+ENTDL                                             LEP27590
      DO 235 N=2,5                                                      LEP27600
  235 ENTB(J,N,1)=ENTB(J,N,1)+ENTBL(N)                                  LEP27610
  240 IF(KW.EQ.0) GO TO 300                                             LEP27620
      IF(J.GT.JKW) GO TO 300                                            LEP27630
      FAC=1.
      IF(J.NE.JKW) GO TO 242
      IF(J.EQ.JMAX) GO TO 242
      FAC=.5
  242 CONTINUE
      CALL GDINTW(2,J,KW,L1,L2,ENTDL,ENTBL)                             LEP27640
      ENTD(J)=ENTD(J)+ENTDL                                             LEP27650
      DO 245 N=2,5                                                      LEP27660
  245 ENTB(J,N,1)=ENTB(J,N,1)+ENTBL(N)*FAC                              LEP27670
      IF(L2.EQ.LW) L2=L2+1                                              LEP27680
      CALL GDINTW(2,J,KW+1,L1,L2,ENTDL,ENTBL)                           LEP27690
      ENTD(J)=ENTD(J)+ENTDL                                             LEP27700
      DO 250 N=2,5                                                      LEP27710
  250 ENTB(J,N,1)=ENTB(J,N,1)+ENTBL(N)*FAC                              LEP27720
  300 CONTINUE                                                          LEP27730
      RETURN                                                            LEP27740
      END                                                               LEP27750
*DECK GLOBAL                                                            LEP27760
      SUBROUTINE GLOBAL(J)                                              LEP27770
*CALL BASE                                                              LEP27780
*CALL VARS1                                                             LEP27790
*CALL BTRID                                                             LEP27800
*CALL GLOB                                                              LEP27810
*CALL VARS2                                                             LEP27820
      GKPR = GAMMA/PR                                                   LEP27830
      PRTR = PR/0.9                                                     LEP27840
C                                                                       LEP27850
C     INTEGRAL OF GENERALIZED STRESSES OVER WALL BOUNDARY L=1 OR L=LMAX LEP27860
C                                                                       LEP27870
      L=1                                                               LEP27880
      IF(LMAXBC.EQ.1) L=LMAX                                            LEP27890
      DO 200 K=1,KMAX                                                   LEP27900
      CALL ZZM(J,K,L,L)                                                 LEP27910
      RA = 1./Q(L,1,K)                                                  LEP27920
      Q2 = (Q(L,2,K)**2 + Q(L,3,K)**2 + Q(L,4,K)**2)*RA                 LEP27930
      T = GD*(Q(L,5,K) - 0.5*Q2)*RA                                     LEP27940
      CALL VISCOF(T,RMUE)                                               LEP27950
      VNU = RMUE                                                        LEP27960
      GKAP = RMUE                                                       LEP27970
C     RECONTRUCT GEOMETRIC JACOBIAN FROM VOLUME-AVERAGED ONE            LEP27980
      Q6L=Q6(L,K)                                                       LEP27990
      LP=L+1                                                            LEP28000
      IF(L.EQ.LMAX) LP=L-1                                              LEP28010
      Q6LP=Q6(LP,K)                                                     LEP28020
      RJ=3./(4.*Q6L-Q6LP)                                               LEP28030
   15 CONTINUE                                                          LEP28040
      S0 = (ZZ(L,1)**2+ZZ(L,2)**2+ZZ(L,3)**2)                           LEP28050
      C(K,1,1)=SQRT(S0)                                                 LEP28060
      S0=S0*RJ                                                          LEP28070
      S1 = (S0+ZZ(L,1)**2/3.*RJ)*VNU                                    LEP28080
      S2 = (S0+ZZ(L,2)**2/3.*RJ)*VNU                                    LEP28090
      S3 = (S0+ZZ(L,3)**2/3.*RJ)*VNU                                    LEP28100
      S4 = (ZZ(L,1)*ZZ(L,2)/3.*RJ)*VNU                                  LEP28110
      S5 = (ZZ(L,1)*ZZ(L,3)/3.*RJ)*VNU                                  LEP28120
      S6 = (ZZ(L,2)*ZZ(L,3)/3.*RJ)*VNU                                  LEP28130
      L1=L+1                                                            LEP28140
      L2=L+2                                                            LEP28150
      IF(L.NE.LMAX) GO TO 20                                            LEP28160
      L1=L-1                                                            LEP28170
      L2=L-2                                                            LEP28180
   20 CONTINUE                                                          LEP28190
      R1=1.0/Q(L,1,K)                                                   LEP28200
      R2=1.0/Q(L1,1,K)                                                  LEP28210
      R3=1.0/Q(L2,1,K)                                                  LEP28220
      DU=(4.0*Q(L1,2,K)*R2-3.0*Q(L,2,K)*R1-Q(L2,2,K)*R3)/(2.0*DZ1)      LEP28230
      DV=(4.0*Q(L1,3,K)*R2-3.0*Q(L,3,K)*R1-Q(L2,3,K)*R3)/(2.0*DZ1)      LEP28240
      DW=(4.0*Q(L1,4,K)*R2-3.0*Q(L,4,K)*R1-Q(L2,4,K)*R3)/(2.0*DZ1)      LEP28250
      E1=(Q(L,5,K)-0.5*Q2)*RA                                           LEP28260
      Q2=R2*(Q(L1,2,K)**2+Q(L1,3,K)**2+Q(L1,4,K)**2)                    LEP28270
      E2=(Q(L1,5,K)-0.5*Q2)*R2                                          LEP28280
      Q2=R3*(Q(L2,2,K)**2+Q(L2,3,K)**2+Q(L2,4,K)**2)                    LEP28290
      E3=(Q(L2,5,K)-0.5*Q2)*R3                                          LEP28300
      DE=(4.0*E2-3.0*E1-E3)/(2.0*DZ1)                                   LEP28310
      GF(1)=0.0                                                         LEP28320
      GF(2)=S1*DU+S4*DV+S5*DW                                           LEP28330
      GF(3)=S2*DV+S4*DU+S6*DW                                           LEP28340
      GF(4)=S3*DW+S5*DU+S6*DV                                           LEP28350
      GF(5)=S0*GKPR*GKAP*DE                                             LEP28360
      CALL FLUXVE(K,L,ZZ(L,1),ZZ(L,2),ZZ(L,3),0.)                       LEP28370
      DO 100 N=1,5                                                      LEP28380
C     CORRECT FOR DIRECTIONALITY OF DU,DV,DW,DE                         LEP28390
      IF(L.EQ.LMAX) GF(N)=-GF(N)                                        LEP28400
  100 A(K,N,1)=FV(N)-GF(N)/RE                                           LEP28410
  200 CONTINUE                                                          LEP28420
      CALL QDRTR(ENTGD(J),C,DY1,1,KMAX)                                 LEP28430
      DO 300 N=1,5                                                      LEP28440
      CALL QDRTR(ENTGD1(J,N),A(1,N,1),DY1,1,KMAX)                       LEP28450
  300 CONTINUE                                                          LEP28460
      RETURN                                                            LEP28470
      END                                                               LEP28480
*DECK GLOINT                                                            LEP28490
      SUBROUTINE GLOINT                                                 LEP28500
*CALL BASE                                                              LEP28510
*CALL GLOB                                                              LEP28520
      NMX=5                                                             LEP28530
      IF(IGFSUR.EQ.0) GO TO 10                                          LEP28540
      NMX=1                                                             LEP28550
      CALL QDRTR(AREF,ENTD,DX1,1,JMAX)                                  LEP28560
      DO 5 N=2,5                                                        LEP28570
      CALL QDRTR(ENTGRL,ENTB(1,N,1),DX1,1,JMAX)                         LEP28580
    5 GF(N)=-ENTGRL                                                     LEP28590
C     NET OUTFLOW INTEGRAL MINUS INFLOW INTEGRAL                        LEP28600
   10 DO 15 N=1,NMX                                                     LEP28610
      GF(N)=-DINJMX(N)+DINJ1(N)                                         LEP28620
   15 CONTINUE                                                          LEP28630
      DO 25 IW=1,2                                                      LEP28640
      DO 20 N=1,NMX                                                     LEP28650
      CALL QDRTR(ENTGRL,ENTB(1,N,IW),DX1,1,JMAX)                        LEP28660
   20 GF(N)=GF(N)-ENTGRL                                                LEP28670
   25 CONTINUE                                                          LEP28680
C     CHANGE SCALING OF GENERALIZED FORCE VECTOR GF(N)                  LEP28690
C     TO REFERENCE VALUES OF INFLOW BOUNDARY MASS FLUX                  LEP28700
C     RRHO*RMACH, DYNAMIC PRESSURE .5*RRHO*RMACH**2, AND                LEP28710
C     KINETIC ENERGY FLUX .5*RRHO*RMACH**3.  REFERENCE AREA             LEP28720
C     IS EQUAL TO SQUARE OF REFERENCE LENGTH.                           LEP28730
      AREF=1.0                                                          LEP28740
      FACM=1.0/RMACH                                                    LEP28750
      GF(1)=FACM*GF(1)/AREF                                             LEP28760
      GF(5)=FACM*GF(5)                                                  LEP28770
      FACM=2.0*FACM*FACM/AREF                                           LEP28780
      DO 30 N=2,5                                                       LEP28790
   30 GF(N)=FACM*GF(N)                                                  LEP28800
      WRITE (6,35)GF,CW                                                 LEP28810
   35 FORMAT(4X,3HGF=1P5E11.4,2X,3HCW=1PE11.4)                          LEP28820
      RETURN                                                            LEP28830
      END                                                               LEP28840
*DECK GRID                                                              LEP28850
      SUBROUTINE GRID                                                   LEP28860
*CALL BASE                                                              LEP28870
*CALL VARS1                                                             LEP28880
*CALL VARS2                                                             LEP28890
C     PUT HERE THE CALCULATION OF THE GRID                              LEP28900
      RETURN                                                            LEP28910
      END                                                               LEP28920
*DECK INFLTR                                                            LEP28930
      SUBROUTINE INFLTR(ISW,LORK)                                       LEP28940
*CALL BASE                                                              LEP28950
*CALL BTRID                                                             LEP28960
*CALL RHSBCC                                                            LEP28970
C     FILTER INTERMEDIATE DELTAQ AT INFLOW BOUNDARY                     LEP28980
      J=1                                                               LEP28990
      I1=2                                                              LEP29000
      IW=4-ISW                                                          LEP29010
      CALL SW                                                           LEP29020
C     FILTER IN LORK DIRECTION                                          LEP29030
      I2=LMORKM                                                         LEP29040
      IF(LORKW.GT.0) I2=LORKW-1                                         LEP29050
      I3=I1-1                                                           LEP29060
      I4=I2+1                                                           LEP29070
      DO 30 N=1,5                                                       LEP29080
      IF(N.EQ.3.OR.N.EQ.4) GO TO 30                                     LEP29090
      DO 10 I=I1,I2                                                     LEP29100
   10 A(I,1,1)=0.25*(F(I+1,N)+F(I-1,N)+2.0*F(I,N))                      LEP29110
      A(1,1,1)=F(1,N)                                                   LEP29120
      A(I2+1,1,1)=F(I2+1,N)                                             LEP29130
      IF(LK1BC.EQ.1.AND.J.GE.JLK1WL.AND.J.LE.JLK1WU) GO TO 15           LEP29140
      A(1,1,1)=0.5*(F(1,N)+F(2,N))                                      LEP29150
   15 IF(I2.EQ.LMORKM.AND.(LKMXBC.EQ.3.OR.LKMXBC.EQ.4))                 LEP29160
     1  A(I2+1,1,1)=0.5*(F(I2,N)+F(I2+1,N))                             LEP29170
      DO 20 I=I3,I4                                                     LEP29180
   20 F(I,N)=A(I,1,1)                                                   LEP29190
   30 CONTINUE                                                          LEP29200
      DO 40 I=I3,I4                                                     LEP29210
      IF(IW.EQ.1) F(I,3)=VOU(I,LORK)*F(I,2)                             LEP29220
      IF(IW.EQ.2) F(I,3)=VOU(LORK,I)*F(I,2)                             LEP29230
      IF(IW.EQ.1) F(I,4)=WOU(I,LORK)*F(I,2)                             LEP29240
      IF(IW.EQ.2) F(I,4)=WOU(LORK,I)*F(I,2)                             LEP29250
   40 CONTINUE                                                          LEP29260
      RETURN                                                            LEP29270
      END                                                               LEP29280
*DECK JACOB                                                             LEP29290
      SUBROUTINE JACOB(JDO)                                             LEP29300
*CALL BASE                                                              LEP29310
*CALL VARS1                                                             LEP29320
*CALL RHSBCC                                                            LEP29330
*CALL VARS2                                                             LEP29340
      COMMON/AXISYM/LAXIS                                               LEP29350
      IWW=2                                                             LEP29360
      IF(KPLANE.EQ.1) IWW=1                                             LEP29370
      J=JDO                                                             LEP29380
      AFAC=.75                                                          LEP29390
      BFAC=.25                                                          LEP29400
C     UPPER BOUNDARY SURFACE L=LORKMX                                   LEP29410
      DO 35 IW=1,IWW                                                    LEP29420
      CALL SW                                                           LEP29430
      IF(LKMXBC.NE.1) GO TO 35                                          LEP29440
      L=LORKMX                                                          LEP29450
      IF(L.EQ.1) GO TO 35                                               LEP29460
      DO 30 K=1,KORLMX                                                  LEP29470
      IF(IW.EQ.1) Q6(L,K)=AFAC*Q6(L,K)+BFAC*Q6(L-1,K)                   LEP29480
      IF(IW.EQ.2) Q6(K,L)=AFAC*Q6(K,L)+BFAC*Q6(K,L-1)                   LEP29490
   30 CONTINUE                                                          LEP29500
   35 CONTINUE                                                          LEP29510
      IF(LAXIS.EQ.0) GO TO 40                                           LEP29520
C     AXIAL SYMMETRY AT L=1 FOR ALL K,J                                 LEP29530
      DO 37 K=1,KMAX                                                    LEP29540
      Q6(1,K)=AFAC*Q6(1,K)+BFAC*Q6(2,K)                                 LEP29550
   37 CONTINUE                                                          LEP29560
   40 CONTINUE                                                          LEP29570
C     LOWER BOUNDARY SURFACE LORK=1                                     LEP29580
      L=1                                                               LEP29590
      DO 55 IW=1,IWW                                                    LEP29600
      CALL SW                                                           LEP29610
      IF(J.LT.JLK1WL) GO TO 55                                          LEP29620
      IF(J.GT.JLK1WU) GO TO 55                                          LEP29630
      IF(KORLW.EQ.0) KLIM=KORLMX                                        LEP29640
      IF(KORLW.GT.0) KLIM=KORLW                                         LEP29650
      DO 50 K=1,KLIM                                                    LEP29660
      IF(IW.EQ.1) Q6(L,K)=AFAC*Q6(L,K)+BFAC*Q6(L+1,K)                   LEP29670
      IF(IW.EQ.2) Q6(K,L)=AFAC*Q6(K,L)+BFAC*Q6(K,L+1)                   LEP29680
   50 CONTINUE                                                          LEP29690
   55 CONTINUE                                                          LEP29700
C     INTERIOR AND EXTERIROR SURFACES OF AN INTERNAL WALL AT L =LORKW   LEP29710
      DO 70 IW=1,IWW                                                    LEP29720
      CALL SW                                                           LEP29730
      IF(J.GT.JLKW) GO TO 70                                            LEP29740
      IF(LORKW.LE.0) GO TO 70                                           LEP29750
      IF(KORLW.EQ.0) KLIM=KORLMX                                        LEP29760
      IF(KORLW.GT.0) KLIM=KORLW+1                                       LEP29770
      L=LORKW                                                           LEP29780
      DO 60 K=1,KLIM                                                    LEP29790
      IF(IW.EQ.1) Q6(L,K)=AFAC*Q6(L,K)+BFAC*Q6(L-1,K)                   LEP29800
      IF(IW.EQ.2) Q6(K,L)=AFAC*Q6(K,L)+BFAC*Q6(K,L-1)                   LEP29810
      IF(IW.EQ.1) Q6(L+1,K)=AFAC*Q6(L+1,K)+BFAC*Q6(L+2,K)               LEP29820
      IF(IW.EQ.2) Q6(K,L+1)=AFAC*Q6(K,L+1)+BFAC*Q6(K,L+2)               LEP29830
   60 CONTINUE                                                          LEP29840
   70 CONTINUE                                                          LEP29850
C     EXTERIOR EDGE WHERE TWO INTERNAL WALLS INTERSECT WHEN BOTH WALLS  LEP29860
C     ARE PRESENT AND ONE WALL IS LONGER THAN THE OTHER                 LEP29870
      IF(KPLANE.EQ.1) GO TO 100                                         LEP29880
      DO 90 IW=1,2                                                      LEP29890
      CALL SW                                                           LEP29900
      IF(KORLW.LE.0) GO TO 90                                           LEP29910
      IF(LORKW.LE.0) GO TO 90                                           LEP29920
      IF(J.LT.JLKW+1) GO TO 90                                          LEP29930
      IF(J.GT.JKLW) GO TO 90                                            LEP29940
      L=LORKW                                                           LEP29950
      KS=KORLW+1                                                        LEP29960
      DO 80 K=KORLW,KS                                                  LEP29970
      IF(IW.EQ.1) Q6(L,K)=AFAC*Q6(L,K)+BFAC*Q6(L+1,K)                   LEP29980
      IF(IW.EQ.2) Q6(K,L)=AFAC*Q6(K,L)+BFAC*Q6(K,L+1)                   LEP29990
   80 CONTINUE                                                          LEP30000
   90 CONTINUE                                                          LEP30010
  100 CONTINUE                                                          LEP30020
C     WRITE(6,900) J                                                    LEP30030
C 900 FORMAT(5X,'J='I4)                                                 LEP30040
C     WRITE(6,905)                                                      LEP30050
C 905 FORMAT(3X,'K'T15'1'T30'2'T45'3'T60'4'T75'5'T90'6'T105'7'          LEP30060
C    1  T120'8')                                                        LEP30070
C     DO 110 K=1,KMAX                                                   LEP30080
C     WRITE(6,910) K,(Q6(I,K),I=1,8)                                    LEP30090
C 110 CONTINUE                                                          LEP30100
C     WRITE(6,906)                                                      LEP30110
C 906 FORMAT(3X,'K'T15'9'T30'10'T45'11'T60'12'T75'13'T90'14'T105'15')   LEP30120
C     DO 115 K=1,KMAX                                                   LEP30130
C     WRITE(6,910) K,(Q6(I,K),I=9,15)                                   LEP30140
C 910 FORMAT(2X,I2,1X,1P8E15.8)                                         LEP30150
C 115 CONTINUE                                                          LEP30160
      RETURN                                                            LEP30170
      END                                                               LEP30180
*DECK LJPIO                                                             LEP30190
      SUBROUTINE LJPIO(K,N)                                             LEP30200
*CALL VARS1                                                             LEP30210
*CALL BASE                                                              LEP30220
*CALL VARS2                                                             LEP30230
      CALL DMPAST(13,(K-1)*NLROW,1)                                     LEP30240
      DO 10 J=1 ,JMAX                                                   LEP30250
      IF(N.EQ.1)  CALL DMWAST(13,Q(1,1,J),NLROW)                        LEP30260
      IF(N.EQ.2)  CALL DMRAST(13,Q(1,1,J),NLROW)                        LEP30270
      CALL DMPAST(13,NLSKIP,-1)                                         LEP30280
   10 CONTINUE                                                          LEP30290
      RETURN                                                            LEP30300
      END                                                               LEP30310
*DECK LKPIO                                                             LEP30320
      SUBROUTINE LKPIO(J,N)                                             LEP30330
*CALL VARS1                                                             LEP30340
*CALL BASE                                                              LEP30350
*CALL VARS2                                                             LEP30360
      CALL DMPAST(13,(J-1)*NKLP,1)                                      LEP30370
      IF(N.EQ.1)  CALL DMWAST(13,Q,NKLP)                                LEP30380
      IF(N.EQ.2)  CALL DMRAST(13,Q,NKLP)                                LEP30390
      RETURN                                                            LEP30400
      END                                                               LEP30410
*DECK MUTMIX                                                            LEP30420
      SUBROUTINE MUTMIX(L1,L2)                                          LEP30430
*CALL BASE                                                              LEP30440
*CALL VARS1                                                             LEP30450
      COMMON/VISC/TAS(32),UU(32),SNOR(32),TMO(32),TMI(32),TURMT(32),    LEP30460
     1   DS(32),U(32),V(32),W(32),E(32),RR(32)                          LEP30470
*CALL VARS2                                                             LEP30480
C     TURBULENT KINEMATIC VISCOSITY FOR MIXING LAYER AND FULLY DEVELOPEDLEP30490
C     JET REGION                                                        LEP30500
C     CALCULATE MAXIMUM VORTICITY AND VELOCITY EXTREMA                  LEP30510
      TASMAX=1.E-5                                                      LEP30520
      UMAX=UU(L1)                                                       LEP30530
      UMIN=UU(L1)                                                       LEP30540
      LMIN=L1+1                                                         LEP30550
      DO 1 L=LMIN,L2                                                    LEP30560
      IF(TAS(L).GT.TASMAX) TASMAX=TAS(L)                                LEP30570
      IF(UU(L).GT.UMAX) UMAX=UU(L)                                      LEP30580
      IF(UU(L).LT.UMIN) UMIN=UU(L)                                      LEP30590
    1 CONTINUE                                                          LEP30600
C     CALCULATE TURBULENT VISCOSITY                                     LEP30610
      DO 10 L=L1,L2                                                     LEP30620
      IF(TASMAX) 4,4,6                                                  LEP30630
    4 TURMT(L)=0                                                        LEP30640
      GO TO 10                                                          LEP30650
C     MIXING LENGTH                                                     LEP30660
   6  ELMIX=0.13*ABS(UMAX-UMIN)/TASMAX                                  LEP30670
C     KINEMATIC VISCOSITY OVER RE                                       LEP30680
      TURMT(L)=(ELMIX**2)*TAS(L)                                        LEP30690
   10 CONTINUE                                                          LEP30700
      RETURN                                                            LEP30710
      END                                                               LEP30720
*DECK MUTSPF                                                            LEP30730
      SUBROUTINE MUTSPF(IW,LORK,J,KORL,SPFAC)                           LEP30740
*CALL BASE                                                              LEP30750
*CALL VARS1                                                             LEP30760
*CALL VARS2                                                             LEP30770
C     COMPUTE EXPONENT SPFAC IN EXPONENTIAL DAMPING FACTOR FOR          LEP30780
C     BOUNDARY LAYER ON A WALL AT L(K)=LORK                             LEP30790
      GO TO (10,20),IW                                                  LEP30800
   10 L=LORK                                                            LEP30810
      K=KORL                                                            LEP30820
      GO TO 30                                                          LEP30830
   20 L=KORL                                                            LEP30840
      K=LORK                                                            LEP30850
   30 RM1=1./Q(L,1,K)                                                   LEP30860
      XKE=.5*(Q(L,2,K)**2+Q(L,3,K)**2+Q(L,4,K)**2)*RM1                  LEP30870
      TT=GD*(Q(L,5,K)-XKE)*RM1                                          LEP30880
      CALL VISCOF(TT,RMUE)                                              LEP30890
      SPFAC=SQRT(RE*Q(L,1,K)/RMUE)                                      LEP30900
      RETURN                                                            LEP30910
      END                                                               LEP30920
*DECK MUTUR                                                             LEP30930
      SUBROUTINE MUTUR(JJ)                                              LEP30940
*CALL BASE                                                              LEP30950
*CALL VARS1                                                             LEP30960
*CALL RHSBCC                                                            LEP30970
      COMMON/VISC/TAS(32),UU(32),SNOR(32),TMO(32),TMI(32),TURMT(32),    LEP30980
     1   DS(32),U(32),V(32),W(32),E(32),RR(32)                          LEP30990
*CALL VARS2                                                             LEP31000
      COMMON/AXISYM/LAXIS                                               LEP31010
      DATA IFIRST/0/                                                    LEP31020
      IFIRST=IFIRST+1                                                   LEP31030
C                                                                       LEP31040
C     CONTROL ROUTINE FOR TURBULENT VISCOSITY TURMU(L,6,K)              LEP31050
C                                                                       LEP31060
      J=JJ                                                              LEP31070
      IF(J.LT.JB) GO TO 3000                                            LEP31080
      DO 2500 IW=1,2                                                    LEP31090
      IF(KPLANE.EQ.1.AND.IW.EQ.2) GO TO 2500                            LEP31100
      IF(LAXIS.EQ.1.AND.KPLANE.EQ.0.AND.IW.EQ.2) GO TO 2500             LEP31110
      CALL SW                                                           LEP31120
      DO 2000 K=KLORLL,KUORLU                                           LEP31130
   10 DO 20 L=LLORKL,LUORKU                                             LEP31140
      GO TO (1,2),IW                                                    LEP31150
    1 LORK=L                                                            LEP31160
      KORL=K                                                            LEP31170
C     ETA METRICS                                                       LEP31180
      CALL YYM(J,L,K,K)                                                 LEP31190
      E(L)=1./SQRT(YY(K,1)**2+YY(K,2)**2+YY(K,3)**2)                    LEP31200
      GO TO 3                                                           LEP31210
    2 LORK=K                                                            LEP31220
      KORL=L                                                            LEP31230
C     ZETZ METRICS                                                      LEP31240
      CALL ZZM(J,L,K,K)                                                 LEP31250
      E(L)=1./SQRT(ZZ(K,1)**2+ZZ(K,2)**2+ZZ(K,3)**2)                    LEP31260
C     VELOCITY COMPONENTS, TOTAL VELOCITY, AND ELEMENTAL ARC            LEP31270
C     LENGTH ALONG LORK LINE                                            LEP31280
    3 RHOI=1./Q(LORK,1,KORL)                                            LEP31290
      U(L)=RHOI*Q(LORK,2,KORL)                                          LEP31300
      V(L)=RHOI*Q(LORK,3,KORL)                                          LEP31310
      W(L)=RHOI*Q(LORK,4,KORL)                                          LEP31320
      UU(L)=SQRT(U(L)**2+V(L)**2+W(L)**2)                               LEP31330
      GO TO (6,7),IW                                                    LEP31340
    6 CALL DLMET(J,K,L,XI,YI,ZI)                                        LEP31350
      GO TO 8                                                           LEP31360
    7 CALL DKMET(J,L,K,XI,YI,ZI)                                        LEP31370
    8 DS(L)=SQRT(XI**2+YI**2+ZI**2)                                     LEP31380
   20 CONTINUE                                                          LEP31390
C     VORTICITY COMPONENT NORMAL TO SURFACE ETA=CONSTANT OR ZETA=CONSTANLEP31400
      DO 999 L=LLORKL,LUORKU                                            LEP31410
      GO TO (31,32),IW                                                  LEP31420
   31 LORK=L                                                            LEP31430
      KORL=K                                                            LEP31440
      D2=.5/DZ1                                                         LEP31450
      GO TO 33                                                          LEP31460
   32 LORK=K                                                            LEP31470
      KORL=L                                                            LEP31480
      D2=.5/DY1                                                         LEP31490
C     XI METRICS                                                        LEP31500
   33 XJ=XXI(L,14,K)                                                    LEP31510
      YJ=YXI(L,15,K)                                                    LEP31520
      ZJ=ZXI(L,16,K)                                                    LEP31530
C     DERIVATIVES OF VELOCITY COMPONENTS IN LORK DIRECTION              LEP31540
      LP=L+1                                                            LEP31550
      LR=L-1                                                            LEP31560
C     INTERMEDIATE WALL IN LORK DIRECTION                               LEP31570
      IF(LORKW.LE.0.OR.L.LT.LORKW.OR.L.GT.LORKW+1.OR.J.GT.JLKW)GO TO 100LEP31580
      IF(KORLW.GT.0.AND.K.GT.KORLW) GO TO 100                           LEP31590
      IF(L.EQ.LORKW) GO TO 700                                          LEP31600
      IF(L.EQ.LORKW+1) GO TO 500                                        LEP31610
  100 IF(L.NE.1) GO TO 600                                              LEP31620
      IF(LAXIS.NE.1) GO TO 150                                          LEP31630
      DU=0.                                                             LEP31640
      DV=V(LP)-V(L)                                                     LEP31650
      DW=W(LP)-W(L)                                                     LEP31660
      GO TO 910                                                         LEP31670
  150 CONTINUE                                                          LEP31680
C     TEST FOR INTERMEDIATE WALL NORMAL TO L=1 SURFACE                  LEP31690
      IF(KORLW) 200,200,400                                             LEP31700
C     TEST FOR WALL AT L=1                                              LEP31710
  200 IF(JLK1WL.LE.J.AND.J.LE.JLK1WU) GO TO 500                         LEP31720
C     SYMMETRY                                                          LEP31730
  300 DU=0.0                                                            LEP31740
      IF(IW.EQ.2) GO TO 310                                             LEP31750
      DV=0.0                                                            LEP31760
      DW=W(LP)-W(L)                                                     LEP31770
      GO TO 910                                                         LEP31780
  310 DV=V(LP)-V(L)                                                     LEP31790
      DW=0.                                                             LEP31800
      GO TO 910                                                         LEP31810
C     TEST FOR WALL AT L=1                                              LEP31820
  400 IF(K-KORLW) 200,200,300                                           LEP31830
C     FORWARD DIFFERENCE                                                LEP31840
  500 LR=L                                                              LEP31850
      FAC=2.0                                                           LEP31860
      GO TO 900                                                         LEP31870
  600 IF(L.NE.LORKMX) GO TO 800                                         LEP31880
      IF(LKMXBC.LT.3.OR.LKMXBC.GT.4) GO TO 700                          LEP31890
C     SYMMETRY                                                          LEP31900
      DU=0.0                                                            LEP31910
      DV=0.0                                                            LEP31920
      DW=0.0                                                            LEP31930
      LR=LR                                                             LEP31940
      IF(LKMXBC.EQ.4) DW=W(L)-W(LR)                                     LEP31950
      IF(LKMXBC.EQ.3) DV=V(L)-V(LR)                                     LEP31960
      GO TO 910                                                         LEP31970
C     BACKWARD DIFFERENCE                                               LEP31980
  700 LP=L                                                              LEP31990
      FAC=2.0                                                           LEP32000
      GO TO 900                                                         LEP32010
C     CENTRAL DIFFERENCE                                                LEP32020
  800 FAC=1.0                                                           LEP32030
  900 LR=LR                                                             LEP32040
      LP=LP                                                             LEP32050
      DU=(U(LP)-U(LR))*D2*FAC                                           LEP32060
      DV=(V(LP)-V(LR))*D2*FAC                                           LEP32070
      DW=(W(LP)-W(LR))*D2*FAC                                           LEP32080
  910 CONTINUE                                                          LEP32090
C     VORTICITY COMPONENT                                               LEP32100
      TAS(L)=ABS(XJ*DU+YJ*DV+ZJ*DW)*E(L)                                LEP32110
  999 CONTINUE                                                          LEP32120
C     COMPUTE TURBULENT KINEMATIC VISCOSITY OVER RE,TURMT(L), ALONG THE LEP32130
C     CURRENT LORK LINE AND STORE TEMPORARILY IN S(KL,IW,J)             LEP32140
C                                                                       LEP32150
C     CONFIGURATIONS WITHOUT INTERMEDIATE WALLS (PURE EXTERNAL OR PURE  LEP32160
C     INTERNAL FLOW)                                                    LEP32170
      IF(KW.GT.0 .OR. LW.GT.0) GO TO 1200                               LEP32180
C     UPPER WALL PRESENT?                                               LEP32190
      IF(LKMXBC-1) 1000,1020,1000                                       LEP32200
C     NO UPPER WALL                                                     LEP32210
 1000 L2=LORKMX                                                         LEP32220
      L1=1                                                              LEP32230
C     LOWER WALL PRESENT?                                               LEP32240
      IF(LK1BC*JLK1WU) 9000,9000,1001                                   LEP32250
C     LOWER WALL OR ITS WAKE                                            LEP32260
 1001 IF(J-JLK1WU) 1002,1002,8000                                       LEP32270
 1002 IF(J.LT.JLK1WL) GO TO 9000                                        LEP32280
C                                                                       LEP32290
C     WALL BOUNDARY LAYER                                               LEP32300
C                                                                       LEP32310
 7000 CALL MUTSPF(IW,L1,J,K,SPFAC)                                      LEP32320
      CALL MUTWWK(L1,L2,1,SPFAC)                                        LEP32330
      GO TO 1990                                                        LEP32340
C                                                                       LEP32350
C     WAKE OF A WALL                                                    LEP32360
C                                                                       LEP32370
 8000 CALL MUTWWK(L1,L2,0,0.0)                                          LEP32380
      GO TO 1990                                                        LEP32390
C                                                                       LEP32400
C     NO WALLS, WAKES, OR MIXING LAYERS                                 LEP32410
C                                                                       LEP32420
 9000 DO 9100 L=L1,L2                                                   LEP32430
 9100 TURMT(L)=0.0                                                      LEP32440
      GO TO 1990                                                        LEP32450
C                                                                       LEP32460
C                                                                       LEP32470
C                                                                       LEP32480
C     UPPER WALL IS PRESENT                                             LEP32490
 1020 L1=LORKMX                                                         LEP32500
C     LOWER WALL PRESENT?                                               LEP32510
      IF(LK1BC*JLK1WU) 1025,1025,1030                                   LEP32520
C     UPPER WALL BOUNDARY LAYER SPANS ALL LORK                          LEP32530
 1025 L2=1                                                              LEP32540
      GO TO 7000                                                        LEP32550
C     BOTH UPPER AND LOWER WALLS ARE PRESENT                            LEP32560
 1030 IF(J.LT.JLK1WL) GO TO 1025                                        LEP32570
C *** THE VARIABLE LEDGE DEFINES THE COMPUTATIONAL SUBDOMAIN            LEP32580
C *** 1.LE.LORK.LT.LEDGE THAT IS SPANNED BY THE LOWER WALL B.L.         LEP32590
C *** OR WAKE AND THE SUBDOMAIN LEDGE.LE.LORK.LE.LORKMX                 LEP32600
C *** THAT IS SPANNED BY THE UPPER WALL B.L. LEDGE IS CURRENTLY         LEP32610
C *** TAKEN AT THE POINT OF MAXIMUM TOTAL VELOCITY                      LEP32620
      UMAX=0.                                                           LEP32630
      DO 1040 L=1,LORKMX                                                LEP32640
      IF(UU(L).LT.UMAX) GO TO 1040                                      LEP32650
      UMAX=UU(L)                                                        LEP32660
      LEDGE=L                                                           LEP32670
 1040 CONTINUE                                                          LEP32680
C     UPPER WALL B.L.                                                   LEP32690
      L2=LEDGE                                                          LEP32700
      CALL MUTSPF(IW,L1,J,K,SPFAC)                                      LEP32710
      CALL MUTWWK(L1,L2,1,SPFAC)                                        LEP32720
C     LOWER WALL B.L. OR WAKE                                           LEP32730
      L1=1                                                              LEP32740
      L2=LEDGE-1                                                        LEP32750
      IF(J-JLK1WU) 7000,7000,8000                                       LEP32760
C *** LOGIC FOR FULL 3D NOZZLE CONFIGURATION                            LEP32770
C *** THAT HAS INTERMEDIATE WALLS AND SIDE PLATES LORKW.GT.0            LEP32780
 1200 CONTINUE                                                          LEP32790
C     DEFINE THE TOLERANCE EPSWAK TO DISTINGUISH WAKES                  LEP32800
C     FROM MIXING LAYERS.  IF THE MAXIMUM VELOCITY DEFECT VMIN-VMAX     LEP32810
C     IN A PROFILE SATISFIES VMIN.LT.EPSWAK*VMAX, WE HAVE               LEP32820
C     A WAKE.  OTHERWISE, WE HAVE A MIXING LAYER                        LEP32830
      EPSWAK=0.9                                                        LEP32840
C      IS A SIDEWALL/SIDEPLATE PRESENT?                                 LEP32850
      IF(KORLW) 1300,1300,1210                                          LEP32860
C     SIDEWALL/SIDEPLATE PRESENT                                        LEP32870
 1210 IF(K-KORLW) 1300,1220,1225                                        LEP32880
 1225 IF(K-(KORLW+1))1220,1220,1230                                     LEP32890
C     REGION OUTSIDE SIDEWALL/SIDEPLATE                                 LEP32900
C     MIXING LAYER                                                      LEP32910
 1230 CALL MUTMIX(1,LORKMX)                                             LEP32920
      GO TO 1990                                                        LEP32930
C     IN PLANE OF SIDEWALL/SIDEPLATE K=KORLW,KORLW+1                    LEP32940
 1220 IF(J-MAX0(JKLW,JLKW)) 1250,1250,1235                              LEP32950
C     REGION DOWNSTREAM OF ALL WALLS                                    LEP32960
 1235 UMIN=UU(1)                                                        LEP32970
      LMIN=1                                                            LEP32980
      DO 1236 L=2,LORKMX                                                LEP32990
      IF(UU(L).GT.UMIN) GO TO 1236                                      LEP33000
      UMIN=UU(L)                                                        LEP33010
      LMIN=L                                                            LEP33020
 1236 CONTINUE                                                          LEP33030
C     WAKE OR MIXING LAYER? TEST UMIN AGAINST UINF                      LEP33040
      IF(UMIN-EPSWAK*UU(LORKMX)) 1240,1230,1230                         LEP33050
C     WAKE                                                              LEP33060
 1240 CALL MUTWWK(LMIN,LORKMX,0,0.0)                                    LEP33070
      CALL MUTWWK(LMIN,1,0,0.0)                                         LEP33080
      GO TO 1990                                                        LEP33090
C     REGION OF SIDEWALL/SIDEPLATE                                      LEP33100
C     BOUNDARY LAYER ON UPPER SURFACE OF WALL                           LEP33110
 1250 CALL MUTSPF(IW,LORKW+1,J,K,SPFAC)                                 LEP33120
      CALL MUTWWK(LORKW+1,LORKMX,1,SPFAC)                               LEP33130
C     BOUNDARY LAYER OR VERTICAL WALL SURFACE BELOW L=LORKW             LEP33140
       IF(J-JKLW) 9000,9000,1260                                        LEP33150
 1260 CALL MUTSPF(IW,LORKW,J,K,SPFAC)                                   LEP33160
      CALL MUTWWK(LORKW,1,1,SPFAC)                                      LEP33170
      GO TO 1990                                                        LEP33180
C     IN REGION BETWEEN SYMMETRY PLANE K=1 AND SIDEWALL/SIDEPLATE K=KORLLEP33190
C     LOWER WALL PRESENT AT L=1 ?                                       LEP33200
 1300 IF(JLK1WU) 1310,1310,1500                                         LEP33210
C     NO LOWER WALL                                                     LEP33220
 1310 IF(J.GT.JLKW) GO TO 1400                                          LEP33230
C     BOUNDARY LAYER ON LOWER SURFACE LORKW OF INTERMEDIATE WALL        LEP33240
      CALL MUTSPF(IW,LORKW,J,K,SPFAC)                                   LEP33250
      CALL MUTWWK(LORKW,1,1,SPFAC)                                      LEP33260
C     BOUNDARY LAYER ON UPPER SURFACE OF INTERMEDIATE WALL              LEP33270
      CALL MUTSPF(IW,LORKW+1,J,K,SPFAC)                                 LEP33280
      CALL MUTWWK(LORKW+1,LORKMX,1,SPFAC)                               LEP33290
      GO TO 1990                                                        LEP33300
C     INTERMEDIATE WALL WAKE OR MIXING LAYER                            LEP33310
 1400 UMIN=UU(1)                                                        LEP33320
      LMIN=1                                                            LEP33330
      UMAX=UU(1)                                                        LEP33340
      DO 1401 L=2,LORKMX                                                LEP33350
      IF(UU(L).GT.UMIN) GO TO 1401                                      LEP33360
      UMIN=UU(L)                                                        LEP33370
      LMIN=L                                                            LEP33380
 1401 CONTINUE                                                          LEP33390
      UMAX=AMIN1(UU(1),UU(LORKMX))                                      LEP33400
C     WAKE OR MIXING LAYER?                                             LEP33410
      IF(UMIN-EPSWAK*UMAX) 1410,1410,1230                               LEP33420
C     WAKE  - IF BROAD ENOUGH                                           LEP33430
 1410 IF((LMIN.LE.3).OR.(LMIN.GE.(LMAX-2))) GO TO 1230                  LEP33440
C     INTERMEDIATE WALL WAKE CENTERED AT LMIN                           LEP33450
      CALL MUTWWK(LMIN,1,0,0.0)                                         LEP33460
      CALL MUTWWK(LMIN,LORKMX,0,0.0)                                    LEP33470
      GO TO 1990                                                        LEP33480
 1500 CONTINUE                                                          LEP33490
C     LOWER WALL PRESENT AT L=1                                         LEP33500
      IF(J.GT.MAX0(JLKW,JLK1WU)) GO TO 1700                             LEP33510
C     REGION CONTAINING WALLS                                           LEP33520
      IF(JLKW-JLK1WU) 1520,1520,1510                                    LEP33530
 1510 WRITE(6,1515)                                                     LEP33540
      PRINT 1515                                                        LEP33550
 1515 FORMAT( 2X,45H*****ERROR FLAG IN SUBROUTINE MUTUR ****            LEP33560
     A/2X,58H*****INADMISSIBLE INPUT *****                              LEP33570
     1/2X,58H**THIS SUBROUTINE IS NOT PRESENTLY CODED TO COMPUTE        LEP33580
     2/2X,58H**THE TURBULENT VISCOSITY TURMU FOR PLUGGED NOZZLES        LEP33590
     3/2X,58H**WHERE THE CENTRAL PLUG AT L(K)=1 IS SHORTER THAN THE     LEP33600
     4/2X,58H**UPPER NOZZLE WALL AT L(K)=LW(KW).  THE CURRENT           LEP33610
     5/2X,58H**LOGIC REQUIRES JL1WU .GE. JLW WHEN BOTH ARE POSITIVE     LEP33620
     6/2X,58H**AND NON-ZERO.  ADDITIONAL LOGIC WOULD BE REQUIRED        LEP33630
     7/2X,58H**AFTER STATEMENT 1510 TO HANDLE THE REGION                LEP33640
     8/2X,58H**.0.LE.JL1WU.LE.J.LE.JLW.                                 LEP33650
     9/2X,3H***    )                                                    LEP33660
      STOP                                                              LEP33670
 1520 IF(J.GT.JLKW) GO TO 1600                                          LEP33680
C     REGION J UPSTREAM OF INTERMEDIATE WALL TRAILING EDGE              LEP33690
C     BOUNDARY LAYER ON OUTER SURFACE OF INTERMEDIATE WALL              LEP33700
      CALL MUTSPF(IW,LORKW+1,J,K,SPFAC)                                 LEP33710
      CALL MUTWWK(LORKW+1,LORKMX,1,SPFAC)                               LEP33720
C     BOUNDARY LAYERS INSIDE NOZZLE                                     LEP33730
      L1=LORKW                                                          LEP33740
      L2=1                                                              LEP33750
C     BOUNDARY LAYER ON UPPER WALL AHEAD OF PLUG                        LEP33760
      IF(J.LT.JLK1WL) GO TO 7000                                        LEP33770
C     BOUNDARY LAYERS ON UPPER WALL AND ON LOWER WALL (PLUG)            LEP33780
      UMAX=UU(1)                                                        LEP33790
      LEDGE=1                                                           LEP33800
      DO 1530 L=2,LORKW                                                 LEP33810
      IF(UU(L).LT.UMAX) GO TO 1530                                      LEP33820
      UMAX=UU(L)                                                        LEP33830
      LEDGE=L                                                           LEP33840
 1530 CONTINUE                                                          LEP33850
C     UPPER WALL B.L.                                                   LEP33860
      L2=LEDGE                                                          LEP33870
 1540 CALL MUTSPF(IW,L1,J,K,SPFAC)                                      LEP33880
      CALL MUTWWK(L1,L2,1,SPFAC)                                        LEP33890
      IF(L1.EQ.1) GO TO 1990                                            LEP33900
C     B.L. ON LOWER WALL (PLUG)                                         LEP33910
      L1=1                                                              LEP33920
      GO TO 1540                                                        LEP33930
 1600 CONTINUE                                                          LEP33940
C     SUBREGION BEHIND UPPER NOZZLE WALL AND ABOVE LOWER WALL (PLUG)    LEP33950
      UMAX=UU(1)                                                        LEP33960
      LEDGE=1                                                           LEP33970
      DO 1610 L=2,LORKMX                                                LEP33980
      IF(UU(L).LT.UMAX) GO TO 1610                                      LEP33990
      UMAX=UU(L)                                                        LEP34000
      LEDGE=L                                                           LEP34010
 1610 CONTINUE                                                          LEP34020
C B.L. OVER LOWER WALL (PLUG)                                           LEP34030
      L1=1                                                              LEP34040
      CALL MUTSPF(IW,L1,J,K,SPFAC)                                      LEP34050
      CALL MUTWWK(L1,LEDGE,1,SPFAC)                                     LEP34060
C     UPPER WALL WAKE OR MIXING LAYER OUTSIDE PLUG B.L.                 LEP34070
      UMIN=UU(LEDGE)                                                    LEP34080
      LMIN=LEDGE                                                        LEP34090
      LEDGE=LEDGE+1                                                     LEP34100
      DO 1620 L=LEDGE,LORKMX                                            LEP34110
      IF(UU(L).GT.UMIN) GO TO 1620                                      LEP34120
      UMIN=UU(L)                                                        LEP34130
      LMIN=L                                                            LEP34140
 1620 CONTINUE                                                          LEP34150
C     WAKE OR MIXING LAYER?                                             LEP34160
      IF(UMIN-EPSWAK*AMIN1(UMAX,UU(LORKMX)))1630,1640,1640              LEP34170
C     UPPER WALL WAKE CENTERED AT LMIN                                  LEP34180
 1630 CALL MUTWWK(LMIN,LEDGE,0,0.0)                                     LEP34190
      CALL MUTWWK(LMIN,LORKMX,0,0.0)                                    LEP34200
      GO TO 1990                                                        LEP34210
C     MIXING LAYER                                                      LEP34220
 1640 CALL MUTMIX(LEDGE,LORKMX)                                         LEP34230
      GO TO 1990                                                        LEP34240
 1700 CONTINUE                                                          LEP34250
C     REGION DOWNSTREAM OF ALL WALLS                                    LEP34260
      UMAX=UU(1)                                                        LEP34270
      LEDGE=1                                                           LEP34280
      DO 1710 L=2,LORKMX                                                LEP34290
      IF(UU(L).LT.UMAX) GO TO 1710                                      LEP34300
      UMAX=UU(L)                                                        LEP34310
      LEDGE=L                                                           LEP34320
 1710 CONTINUE                                                          LEP34330
      IF(LEDGE-3) 1720,1720,1730                                        LEP34340
 1720 LEDGE=1                                                           LEP34350
      UMAX=UU(1)                                                        LEP34360
      GO TO 1800                                                        LEP34370
 1730 IF(LEDGE.GE.LORKMX-2) GO TO 1230                                  LEP34380
C     REGION 1.LE.L.LE.LEDGE.  TEST FOR LOWER WALL (PLUG) WAKE.         LEP34390
      IF(UU(1)-EPSWAK*UMAX) 1740,1750,1750                              LEP34400
C     WAKE OF LOWER WALL (PLUG)                                         LEP34410
 1740 CALL MUTWWK(1,LEDGE,0,0.0)                                        LEP34420
      GO TO 1800                                                        LEP34430
C     MIXING LAYER IN LOWER REGION                                      LEP34440
 1750 CALL MUTMIX(1,LEDGE)                                              LEP34450
 1800 CONTINUE                                                          LEP34460
C     UPPER REGION L.GT.LEDGE. LOOK FOR WAKE OF UPPER NOZZLE WALL.      LEP34470
      UMIN=UU(LEDGE)                                                    LEP34480
      LMIN=LEDGE                                                        LEP34490
      LEDGE=LEDGE+1                                                     LEP34500
      DO 1810 L=LEDGE,LORKMX                                            LEP34510
      IF(UU(L).GT.UMIN) GO TO 1810                                      LEP34520
      UMIN=UU(L)                                                        LEP34530
      LMIN=L                                                            LEP34540
 1810 CONTINUE                                                          LEP34550
C     WAKE OR MIXING LAYER?                                             LEP34560
      IF(LMIN.GT.LEDGE+2) GO TO 1830                                    LEP34570
C     MIXING LAYER                                                      LEP34580
 1820 CALL MUTMIX(LEDGE,LORKMX)                                         LEP34590
      GO TO 1990                                                        LEP34600
 1830 IF(UMIN.GE.EPSWAK*AMIN1(UMAX,UU(LORKMX))) GO TO 1820              LEP34610
C     UPPER WALL WAKE CENTERED ABOUT LMIN                               LEP34620
      CALL MUTWWK(LMIN,LEDGE,0,0.)                                      LEP34630
      CALL MUTWWK(LMIN,LORKMX,0,0.)                                     LEP34640
      GO TO 1990                                                        LEP34650
C     LOAD KINEMATIC VISCOSITY OVER RE TEMPORARILY IN S(KL,IW,1)        LEP34660
 1990 DO 1999 L=LLORKL,LUORKU                                           LEP34670
      GO TO (1991,1992),IW                                              LEP34680
 1991 LORK=L                                                            LEP34690
      KORL=K                                                            LEP34700
      GO TO 1993                                                        LEP34710
 1992 LORK=K                                                            LEP34720
      KORL=L                                                            LEP34730
 1993 S(LORK,IW+8,KORL)=TURMT(L)                                        LEP34740
 1999 CONTINUE                                                          LEP34750
 2000 CONTINUE                                                          LEP34760
 2500 CONTINUE                                                          LEP34770
C     COMBINE INDIVIDUAL VISCOSITY COEFFICIENTS FOR THE K AND L DIRECTIOLEP34780
      IF(KPLANE) 2300,2300,2100                                         LEP34790
 2100 DO 2200 L=LL,LU                                                   LEP34800
      DO 2200 K=KAL,KU                                                  LEP34810
      TURMU(L,6,K)=RE*Q(L,1,K)*S(L,9,K)                                 LEP34820
 2200 CONTINUE                                                          LEP34830
      GO TO 3000                                                        LEP34840
 2300 IF(LAXIS.EQ.1) GO TO 2100                                         LEP34850
      DO 2400 L=LL,LU                                                   LEP34860
      DO 2400 K=KAL,KU                                                  LEP34880
      TURMU(L,6,K)=RE*Q(L,1,K)*SQRT(S(L,9,K)**2+S(L,10,K)**2)           LEP34890
 2400 CONTINUE                                                          LEP34900
 3000 CONTINUE                                                          LEP34910
C      IF(IFIRST.EQ.1) CALL TURCHK                                      LEP34920
      RETURN                                                            LEP34930
      END                                                               LEP34940
*DECK MUTWWK                                                            LEP34950
      SUBROUTINE MUTWWK(L1,L2,IWALL,SPFAC)                              LEP34960
*CALL BASE                                                              LEP34970
*CALL VARS1                                                             LEP34980
      COMMON/VISC/TAS(32),UU(32),SNOR(32),TMO(32),TMI(32),TURMT(32),    LEP34990
     1   DS(32),U(32),V(32),W(32),E(32),FF(32)                          LEP35000
*CALL VARS2                                                             LEP35010
      DATA FK,AP,FKK,F27,FCWK,FCKLEB,FELMIX/0.4,26.,.0168,1.6,.5,.3,.26/LEP35020
C     TURBULENT KINEMATIC VISCOSITY FOR WALL BOUNDARY LAYER (IWALL=1)   LEP35030
C     OR WAKE (IWALL=0) WHERE WALL (OR WAKE CENTER) IS AT L=L1 AND B.L. LEP35040
C     OR WAKE EDGE IS AT L=L2                                           LEP35050
C     ARC LENGTH SNOR, MAXIMUM VORTICITY, VELOCITY EXTREMA, AND         LEP35060
C     VORTICITY FUNCTION FF.                                            LEP35070
      RA=SPFAC*SQRT(TAS(L1))/AP                                         LEP35080
      IDL=1                                                             LEP35090
      IF(L1.GT.L2) IDL=-1                                               LEP35100
      L=L1                                                              LEP35110
      I2=IABS(L2-L1)+1                                                  LEP35120
      IM=1                                                              LEP35130
      SNOR(1)=0.                                                        LEP35140
      TASMAX=TAS(L1)                                                    LEP35150
C     MAX VORTICITY AND ITS LOCATION
      ITASMX=1
      DO 1 I=2,I2
      L=L+IDL
      IF(TAS(L).LE.TASMAX) GO TO 1
      TASMAX=TAS(L)
      ITASMX=I
    1 CONTINUE
C     FIRST MINIMUM BEYOUND ABSOLUTE VORTICITY MAX.DETERMINES
C     THE RANGE OF FF(I)
C     TO AVOID SPURIOUS PEAKS OUTSIDE THE SENSIBLE BOUNDARY LAYER
C     OR WAKE REGION
      IFF=ITASMX
      L=L1
      DO 2 I=2,I2
      L=L+IDL
      IF(I.LE.ITASMX) GO TO 2
      IF(TAS(L).LE.TAS(L-IDL)) GO TO 2
      IFF=I
      GO TO 3
    2 CONTINUE
    3 L=L1
      UMAX=UU(L1)                                                       LEP35160
      UMIN=UU(L1)                                                       LEP35170
      FF(1)=0.                                                          LEP35180
      FFMAX=0.                                                          LEP35190
      SNMAX=.5*(DS(L1)+DS(L1+IDL))                                      LEP35200
      DO 5 I=2,I2
      L=L+IDL
      SNOR(I)=SNOR(I-1)+.5*(DS(L)+DS(L-IDL))
      E1=RA*SNOR(I)
      IF(E1.GT.50) E1=50.
      FF(I)=SNOR(I)*TAS(L)*(1.-IWALL*EXP(-E1))
    5 CONTINUE
      L=L1
      DO 10 I=2,I2                                                      LEP35210
      L=L+IDL                                                           LEP35220
      IF(UU(L).GT.UMAX) UMAX=UU(L)                                      LEP35250
      IF(UU(L).LT.UMIN) UMIN=UU(L)                                      LEP35260
      E1=RA*SNOR(I)
      IF(E1.GT.50) E1=50.
      FF(I)=SNOR(I)*TAS(L)*(1.-IWALL*EXP(-E1))
      IF(I.GT.IFF) GO TO 10
      IF(FF(I).LT.FFMAX) GO TO 9                                        LEP35280
      IM=I                                                              LEP35290
      FFMAX=FF(I)                                                       LEP35300
      SNMAX=SNOR(I)                                                     LEP35310
      GO TO 10
    9 IF(IM.EQ.1) GO TO 10
      IF(IWALL.NE.1) GO TO 10
C     FOR WALL BOUNDARY LAYER STOP WITH FIRST MAXIMUM FOUND
C
      IF(FF(I).LE.FFMAX) GO TO 15
   10 CONTINUE
   15 CONTINUE
C     INTERPOLATE FOR MAXIMUM POINT OF FF                               LEP35330
      IF(IM.EQ.1 .OR. IM.EQ.I2) GO TO 20                                LEP35340
      IMP=IM+1                                                          LEP35350
      IMM=IM-1                                                          LEP35360
      BM=.5*(FF(IMP)-FF(IMM))                                           LEP35370
      AM=BM-FF(IM)                                                      LEP35380
      IF(AM.EQ.0) GO TO 20
      DIM=.5*BM/AM                                                      LEP35390
      IF(ABS(DIM).GE.1) GO TO 20                                        LEP35400
      IF(AM.GE.0.) GO TO 20                                             LEP35410
      FFMAX=FF(IM)-.5*(BM**2)/AM                                        LEP35420
      BM=.5*(SNOR(IMP)-SNOR(IMM))                                       LEP35430
      AM=BM-SNOR(IM)                                                    LEP35440
      SNMAX=SNOR(IM)-DIM*(BM-DIM*AM)                                    LEP35450
   20 CONTINUE                                                          LEP35460
C     OUTER VISCOSITY                                                   LEP35470
      UDIFF=ABS(UMAX-UMIN)                                              LEP35480
      FWAK=SNMAX*FFMAX                                                  LEP35490
      IF(FFMAX.GT.FCWK*UDIFF) FWAK=SNMAX*((FCWK*UDIFF)**2)/FFMAX        LEP35500
      DO 30 I=1,I2                                                      LEP35510
      FIA=FCKLEB*SNOR(I)/SNMAX                                          LEP35520
      IF(FIA.GT.1.E5) FIA=1.E5                                          LEP35530
      TMO(I)=FKK*F27*FWAK/(1.+5.5*FIA**6)                               LEP35540
   30 CONTINUE                                                          LEP35550
C     INNER VISCOSITY                                                   LEP35560
      L=L1-IDL                                                          LEP35570
      IF(IWALL.EQ.0) GO TO 50                                           LEP35580
C     WALL BOUNDARY LAYER                                               LEP35590
      DO 40 I=1,I2                                                      LEP35600
      L=L+IDL                                                           LEP35610
      E1=RA*SNOR(I)
      IF(E1.GT.50) E1=50.
      TMI(I)=TAS(L)*(FK*SNOR(I)*(1.-EXP(-E1)))**2
   40 CONTINUE                                                          LEP35630
      GO TO 70                                                          LEP35640
C     WAKE                                                              LEP35650
   50 DO 60 I=1,I2                                                      LEP35660
      L=L+IDL                                                           LEP35670
      IF(TASMAX) 52,52,54                                               LEP35680
   52 TMI(I)=0.                                                         LEP35690
      GO TO 60                                                          LEP35700
   54 TMI(I)=TAS(L)*(FELMIX*UDIFF/TASMAX)**2                            LEP35710
   60 CONTINUE                                                          LEP35720
C     LOAD VISCOSITIES INTO ARRAY, USING INNER VALUE UNTIL MATCH POINT ILEP35730
C     REACHED                                                           LEP35740
   70 I=1                                                               LEP35750
      L=L1                                                              LEP35760
   80 TURMT(L)=TMI(I)                                                   LEP35770
      I=I+1                                                             LEP35780
      L=L+IDL                                                           LEP35790
      IF(I.GT.I2) GO TO 90                                              LEP35800
      IF(TMI(I).LE.TMO(I)) GO TO 80                                     LEP35810
   81 TURMT(L)=TMO(I)                                                   LEP35820
      I=I+1                                                             LEP35830
      L=L+IDL                                                           LEP35840
      IF(I.LE.I2) GO TO 81                                              LEP35850
C      THE TURMT ARRAY CONTAINS THE KINEMATIC VISCOSITY OVER RE         LEP35860
   90 RETURN                                                            LEP35870
      END                                                               LEP35880
*DECK NEWDT                                                             LEP35890
      SUBROUTINE NEWDT(DQ0QMX,IDTSW)                                    LEP35900
*CALL BASE                                                              LEP35910
      DATA RESIDS/0.0/                                                  LEP35920
      IF(IGNCAL.EQ.1) IGNCAL=2
      NK=NK+1                                                           LEP35930
      IDTSW=0
      IF(ABS(DQ0QMX).GT.OMEGA) GO TO 100
      IF(DTFAC.EQ.1) GO TO 100                                          LEP35940
      DTF=DTMAX/DT                                                      LEP35950
      IF(DTFAC.GT.DTF) DTFAC=DTF                                        LEP35960
      IF(ABS(DTFAC-1.0) .LT.1.E-4) DTFAC=1.0                            LEP35970
      IF(DTFAC.NE.1.0) IDTSW=1
      CNBR=0.0                                                          LEP36060
      IGNCAL=IGNCAL+1
  100 CONTINUE                                                          LEP36080
      RETURN                                                            LEP36090
      END                                                               LEP36100
*DECK OUTALL                                                            LEP36110
      SUBROUTINE OUTALL(NCOUT)                                          LEP36120
*CALL BASE                                                              LEP36130
*CALL VARS1                                                             LEP36140
*CALL VARS2                                                             LEP36150
      COMMON/AXISYM/LAXIS                                               LEP36160
      NPRINT=1                                                          LEP36170
      IF(NCOUT.EQ.NRST .AND. IWRIT.EQ.0) NPRINT=0                       LEP36180
      IGLOB=0                                                           LEP36190
      IF(NCOUT.LT.0) IGLOB=1                                            LEP36200
C                                                                       LEP36210
C                                                                       LEP36220
C     WRITE ON UNIT 4 AND 6                                             LEP36230
C                                                                       LEP36240
      WRITE(4) NC,TAU,DT,NK                                             LEP36250
      IF (NPRINT.EQ.0) GO TO 15                                         LEP36260
      KK=KU                                                             LEP36280
      IF(LAXIS.EQ.1) KK=1
      WRITE (6,10)NC,TAU,DT                                             LEP36300
   10 FORMAT(1H1,5X,52HNOZZLE FLOW FIELD AS WRITTEN TO RESTART FILE AT SLEP36310
     1TEP,I5,9H   TIME =,F10.5,5X,5H  DT=,F10.5//)                      LEP36320
   15 CONTINUE                                                          LEP36330
      DO 45 J=1,JMAX                                                    LEP36340
      CALL LKPIO(J,2)                                                   LEP36350
      DO 20 L=1,LMAX                                                    LEP36360
      CALL DJMET(J,L,XX(J,1),XX(J,2),XX(J,3))                           LEP36370
      DO 20 K=1,KMAX                                                    LEP36380
      Q6(L,K)=Q(L,15,K)                                                 LEP36390
      XXI(L,14,K)=XX(J,1)                                               LEP36400
      YXI(L,15,K)=XX(J,2)                                               LEP36410
      ZXI(L,16,K)=XX(J,3)                                               LEP36420
C     DISCARD TURMU AND PUT X IN ITS PLACE FOR OUTPUT TO RESTART UNIT   LEP36430
      Q(L,6,K)=X(J)                                                     LEP36440
   20 CONTINUE                                                          LEP36450
      IF(IGLOB.EQ.1.AND.KPLANE.EQ.1) CALL GLOBAL(J)                     LEP36460
      IF (NPRINT.EQ.0) GO TO 40                                         LEP36470
      DO 35 K=1,KK
      WRITE (6,25)J,K                                                   LEP36490
   25 FORMAT(1H0,2X,2HJ=,I3,2X,2HK=,I3,2X,1HL,6X,1HX,11X,1HY,11X,1HZ    LEP36500
     1  ,6X,6HR/RREF,5X,6HU/AREF,5X,6HV/AREF,5X,6HW/AREF,5X,6HT/TREF,   LEP36510
     1 5X,6HP/PREF,5X,3HENT)                                            LEP36520
      DO 35 L=1,LMAX                                                    LEP36530
      R = Q(L,1,K)                                                      LEP36540
      RR = 1./R                                                         LEP36550
      U = Q(L,2,K)*RR                                                   LEP36560
      V = Q(L,3,K)*RR                                                   LEP36570
      W = Q(L,4,K)*RR                                                   LEP36580
      E = Q(L,5,K)                                                      LEP36590
      S2=0.0                                                            LEP36600
      IF(ABS(U).GT.1.0E-17) S2=S2+U**2                                  LEP36610
      IF(ABS(V).GT.1.0E-17) S2=S2+V**2                                  LEP36620
      IF(ABS(W).GT.1.0E-17) S2=S2+W**2                                  LEP36630
      PP = GD*(E-.5*R*S2)                                               LEP36640
      TT=PP*RR                                                          LEP36650
      ENT = PP/(ABS(R))**GAMMA                                          LEP36660
      WRITE (6,30)L,X(J),Y(L,7,K),Z(L,8,K),R,U,V,W,TT,PP,ENT            LEP36670
   30 FORMAT(1H ,14X,I3,10F11.6)                                        LEP36680
   35 CONTINUE                                                          LEP36690
   40 CONTINUE                                                          LEP36700
      WRITE(4) (((Q(L,N,K),L=1,LMAX),N=1,8),K=1,KMAX)                   LEP36710
   45 CONTINUE                                                          LEP36720
      IF(IGLOB.EQ.1.AND.KPLANE.EQ.1) CALL GLOANT                        LEP36730
      WRITE (6,50)                                                      LEP36740
   50 FORMAT(1H1)                                                       LEP36750
      RETURN                                                            LEP36760
      END                                                               LEP36770
*DECK PRECAL                                                            LEP36780
      SUBROUTINE PRECAL(J)                                              LEP36790
*CALL BASE                                                              LEP36800
*CALL VARS1                                                             LEP36810
*CALL VARS2                                                             LEP36820
C     PUT RHS & SMOOTHING TERM FOR K & L INTO S FOR NEST STEP           LEP36830
      IF(LAMIN.EQ.0) CALL MUTUR(J)                                      LEP36840
      CALL RHS(J)                                                       LEP36850
      CALL SMOOTH(J)                                                    LEP36860
C     PUT DXIDX,DXIDY,DXIDZ INTO Q ARRAY FOR NEXT STEP                  LEP36870
      DO 100 L=1,LMAX                                                   LEP36880
      CALL XXM(L,J,1,KMAX)                                              LEP36890
      DO 100 K=1,KMAX                                                   LEP36900
      DXIDX(L,14,K)=XX(K,1)                                             LEP36910
      DXIDY(L,15,K)=XX(K,2)                                             LEP36920
      DXIDZ(L,16,K)=XX(K,3)                                             LEP36930
  100 CONTINUE                                                          LEP36940
      IF(J.NE.2) RETURN                                                 LEP36950
C     SET UP FOR SHOCK                                                  LEP36960
      XLSKM2=0.                                                         LEP36970
      ZLSKM2=Z(LMAX-1,8,KM)                                             LEP36980
      XLS22=0.                                                          LEP36990
      ZLS22=Z(LMAX-1,8,KL2)                                             LEP37000
      RETURN                                                            LEP37010
      END                                                               LEP37020
*DECK QDRTR                                                             LEP37030
      SUBROUTINE QDRTR(ENTGRL,ENTGRD,DLT,IL,IU)                         LEP37040
      DIMENSION ENTGRD(1)                                               LEP37050
C   1-D TRAPEZOIDAL QUADRATURE. COMPUTES DEFINITE INTEGRAL,ENTGRL,      LEP37060
C   OF INTEGRAND,ENTGRD(I),BETWEEN LIMITS IL,IU.                        LEP37070
C                                                                       LEP37080
      ENTGRL=0.5*(ENTGRD(IL)+ENTGRD(IU))                                LEP37090
      IF((IU-IL).LT.2) RETURN                                           LEP37100
      ILP=IL+1                                                          LEP37110
      IUM=IU-1                                                          LEP37120
      DO 1 I=ILP,IUM                                                    LEP37130
    1 ENTGRL=ENTGRL+ENTGRD(I)                                           LEP37140
      ENTGRL=ENTGRL*DLT                                                 LEP37150
      RETURN                                                            LEP37160
      END                                                               LEP37170
*DECK RHS                                                               LEP37180
      SUBROUTINE RHS(J)                                                 LEP37190
*CALL BASE                                                              LEP37200
*CALL VARS1                                                             LEP37210
*CALL BTRID                                                             LEP37220
*CALL VARS2                                                             LEP37230
      R0 = -HDZ                                                         LEP37240
      LWR=LW+1                                                          LEP37250
      KWR=KW+1                                                          LEP37260
      IF(KW.LE.0) KWR=KMAX+1
      INTWAL=0
      IF(LW.GT.1.AND.J.LE.JLW) INTWAL=1
      DO 55 K=KAL,KU
      IF(K.GE.KWR) INTWAL=0
      CALL ZZM(J,K,1,LMAX)                                              LEP37310
      DO 15 L=1,LMAX                                                    LEP37320
      CALL FLUXVE(K,L,ZZ(L,1),ZZ(L,2),ZZ(L,3),ZZ(L,4))                  LEP37330
      DO 10 N=1,5                                                       LEP37340
   10 C(L,N,1) = FV(N)                                                  LEP37350
   15 CONTINUE                                                          LEP37360
      ISYMIN=0                                                          LEP37370
      ISYMAX=0                                                          LEP37380
C     TEST FOR SYMMETRY AT LMAX                                         LEP37390
      IF(LMAXBC.EQ.3.OR.LMAXBC.EQ.4) ISYMAX=LMAXBC                      LEP37400
C     TEST FOR WALL AT L=1                                              LEP37430
      IF((K.LT.KWR).AND.(JL1WL.LE.J.AND.J.LE.JL1WU)) GO TO 35
C     SYMMETRY                                                          LEP37450
   25 ISYMIN=4                                                          LEP37460
   35 IF (INTWAL.EQ.0) GO TO 40                                         LEP37500
      CALL DIFFER(R0,1,LW,ISYMIN,0)                                     LEP37510
      CALL DIFFER(R0,LWR,LMAX,0,ISYMAX)                                 LEP37520
      GO TO 45                                                          LEP37530
   40 CALL DIFFER(R0,1,LMAX,ISYMIN,ISYMAX)                              LEP37540
   45 CONTINUE                                                          LEP37550
C     ZTM =ZZ(1,4)/Q6(1,K)                                              LEP37560
C     ZT = ZZ(2,4)/Q6(2,K)                                              LEP37570
      DO 55 L=LL,LU                                                     LEP37580
C     ZTP = ZZ(L+1,4)/Q6(L+1,K)                                         LEP37590
C     DDV = R0*(ZTP - ZTM)                                              LEP37600
      DDV=0.0                                                           LEP37610
      DO 50 N=1,5                                                       LEP37620
   50 S(L,N+8,K) = F(L,N) - DDV*Q(L,N,K)*Q6(L,K)                        LEP37630
C     ZTM = ZT                                                          LEP37640
C     ZT = ZTP                                                          LEP37650
   55 CONTINUE                                                          LEP37660
      IF (KPLANE.EQ.1) GO TO 110                                        LEP37670
      R0 = -HDY                                                         LEP37680
      LWR=LW+1
      IF(LW.LE.0) LWR=LMAX+1
      INTWAL=0
      IF(KW.GT.1.AND.J.LE.JKW) INTWAL=1
      DO 105 L=LL,LU
      IF(L.GE.LWR) INTWAL=0
      CALL YYM(J,L,1,KMAX)                                              LEP37730
      DO 65 K=1,KMAX                                                    LEP37740
         CALL FLUXVE(K,L,YY(K,1),YY(K,2),YY(K,3),YY(K,4))               LEP37750
      DO 60 N=1,5                                                       LEP37760
   60    C(K,N,1) = FV(N)                                               LEP37770
   65    CONTINUE                                                       LEP37780
      ISYMIN=0                                                          LEP37790
      ISYMAX=0                                                          LEP37800
C     TEST FOR SYMMETRY AT KMAX                                         LEP37810
      IF(KMAXBC.EQ.3.OR.KMAXBC.EQ.4) ISYMAX=KMAXBC                      LEP37820
C     TEST FOR WALL AT K=1                                              LEP37850
      IF((L.LT.LWR).AND.(JK1WL.LE.J.AND.J.LE.JK1WU)) GO TO 85
C     SYMMETRY                                                          LEP37870
   75 ISYMIN=3                                                          LEP37880
   85 IF (INTWAL.EQ.0) GO TO 90                                         LEP37920
      CALL DIFFER(R0,1,KW,ISYMIN,0)                                     LEP37930
      CALL DIFFER(R0,KWR,KMAX,0,ISYMAX)                                 LEP37940
      GO TO 95                                                          LEP37950
   90 CALL DIFFER(R0,1,KMAX,ISYMIN,ISYMAX)                              LEP37960
   95 DO 100 N=1,5                                                      LEP37970
      DO 100 K=KAL,KU                                                   LEP37980
  100    S(L,N+8,K) = F(K,N)+S(L,N+8,K)                                 LEP37990
  105    CONTINUE                                                       LEP38000
  110 CONTINUE                                                          LEP38010
      IF(INVISC.NE.0) RETURN                                            LEP38020
C     VISCOUS RIGHT HAND SIDE                                           LEP38030
C     VISCOUS TERMS FOR L DIRECTION                                     LEP38040
      IF(LVIS.EQ.1) CALL DZZDYY(1,J)                                    LEP38050
      IF(KPLANE.EQ.1) RETURN                                            LEP38060
C     VISCOUS TERMS FOR K DIRECTION                                     LEP38070
      IF(KVIS.EQ.1) CALL DZZDYY(2,J)                                    LEP38080
C     VISCOUS CROSS DERIVATIVES                                         LEP38090
      IF(KLVIS.EQ.0) RETURN                                             LEP38100
      CALL DZYDYZ(1,J)                                                  LEP38110
      CALL DZYDYZ(2,J)                                                  LEP38120
      RETURN                                                            LEP38130
      END                                                               LEP38140
*DECK RHSJ                                                              LEP38150
      SUBROUTINE RHSJ(L)                                                LEP38160
*CALL BASE                                                              LEP38170
*CALL VARS1                                                             LEP38180
*CALL BTRID                                                             LEP38190
*CALL VARS2                                                             LEP38200
      R0 = -HDX                                                         LEP38210
      XXJ4=0.0                                                          LEP38220
      DO 15 J=1,JMAX                                                    LEP38230
      XXJ1=DXIDX(L,14,J)                                                LEP38240
      XXJ2=DXIDY(L,15,J)                                                LEP38250
      XXJ3=DXIDZ(L,16,J)                                                LEP38260
      CALL FLUXVE(J,L,XXJ1,XXJ2,XXJ3,XXJ4)                              LEP38270
      DO 10 N=1,5                                                       LEP38280
   10       C(J,N,1) = FV(N)                                            LEP38290
   15       CONTINUE                                                    LEP38300
      CALL DIFFER(R0,1,JMAX,0,0)                                        LEP38310
      DO 20 J=JB,JMAX                                                   LEP38320
      DO 20 N=1,5                                                       LEP38330
   20       S(L,N+8,J) = F(J,N)+S(L,N+8,J)                              LEP38340
      RETURN                                                            LEP38350
      END                                                               LEP38360
*DECK SHOCK                                                             LEP38370
      SUBROUTINE SHOCK                                                  LEP38380
*CALL BASE                                                              LEP38390
*CALL VARS1                                                             LEP38400
*CALL SHOCKC                                                            LEP38410
*CALL VARS2                                                             LEP38420
C     COMPUTE CARTESIAN VELOCITY COMPONTS OF SHOCK SURFACE GRID PTS L=LSLEP38430
      SHKWT = 0.                                                        LEP38440
      SHKWT = 0.1                                                       LEP38450
      LS=LMAX-1                                                         LEP38460
      LSP = LMAX-4                                                      LEP38470
      OJM2 = 1./(JMAX-2)                                                LEP38480
      DX2=.5/DX1                                                        LEP38490
      DY2=.5/DY1                                                        LEP38500
      DZ2=.5/DZ1                                                        LEP38510
      PI=4.0*ATAN(1.0)                                                  LEP38520
      CS=COS(PI*ALP/180.0)                                              LEP38530
      SS=SIN(PI*ALP/180.0)                                              LEP38540
      GAMP=GAMMA+1.0                                                    LEP38550
C   SHOCK SPEEDS ON REGULAR ZETA LINES OF MESH                          LEP38560
      L=LS                                                              LEP38570
      DO 15  J = 2,JMAX                                                 LEP38580
      JP=J+1                                                            LEP38590
      JR=J-1                                                            LEP38600
      PWT = (J-2)*OJM2                                                  LEP38610
      DO 10 K=KAL,KU                                                    LEP38620
C     SHOCK GRID POINT VELOCITY COMPONENTS                              LEP38630
      QSZETA=0.0                                                        LEP38640
      XL=0.0                                                            LEP38650
      YL=0.0                                                            LEP38660
      ZL=0.0                                                            LEP38670
      AL = SQRT(XL**2 + YL**2 + ZL**2)                                  LEP38680
      QS(J,K) = QSZETA*AL                                               LEP38690
      QSZETA = QSZETA*SHKWT                                             LEP38700
      XST(J,K)=QSZETA*XL                                                LEP38710
      YST(J,K)=QSZETA*YL                                                LEP38720
      ZST(J,K)=QSZETA*ZL                                                LEP38730
   10 CONTINUE                                                          LEP38740
      IF(KPLANE.EQ.1) GO TO 15                                          LEP38750
C     QS(J,1) = QS(J,3)                                                 LEP38760
C     QS(J,KMAX) = QS(J,KMAX-2)                                         LEP38770
C     XST(J,1)=XST(J,3)                                                 LEP38780
C     XST(J,KMAX)=XST(J,KMAX-2)                                         LEP38790
C     YST(J,1)=-YST(J,3)                                                LEP38800
C     YST(J,KMAX)=-YST(J,KMAX-2)                                        LEP38810
C     ZST(J,1)=ZST(J,3)                                                 LEP38820
C     ZST(J,KMAX)=ZST(J,KMAX-2)                                         LEP38830
   15 CONTINUE                                                          LEP38840
C   SHOCK SPEED ON SINGULAR ZETA LINE J = 1                             LEP38850
      XJ = (XLSKM2-XLS22)*DX2                                           LEP38860
      ZJ = (ZLSKM2-XLS22)*DX2                                           LEP38870
      AN = SQRT(XJ**2 + ZJ**2)                                          LEP38880
      XN = -ZJ                                                          LEP38890
      ZN = XJ                                                           LEP38900
      QSN = 0.                                                          LEP38910
      XST0 = QSN*SHKWT                                                  LEP38920
      DO 1  K = 1,KMAX                                                  LEP38930
      QS(1,K) = QSN                                                     LEP38940
      XST(1,K) = XST0                                                   LEP38950
      XST(1,K) = 0.                                                     LEP38960
      YST(1,K) = 0.                                                     LEP38970
    1 ZST(1,K) = 0.                                                     LEP38980
      WRITE(3) NC,TAU,DT,                                               LEP38990
     1         ((QS(J,K),J = 1,JMAX),K = 1,KMAX)                        LEP39000
   11 RETURN                                                            LEP39010
      END                                                               LEP39020
*DECK SMOOTH                                                            LEP39030
      SUBROUTINE SMOOTH(JJ)                                             LEP39040
*CALL BASE                                                              LEP39050
*CALL VARS1                                                             LEP39060
*CALL VARS2                                                             LEP39070
      COMMON/AXISYM/LAXIS                                               LEP39080
      DIMENSION CDM(5)                                                  LEP39090
C     GLOBALLY FULLY CONSERVATIVE SMOOTHING                             LEP39100
                                                                        LEP39110
C     ZETA(L) DIRECTION OR ETA(K) DIRECTION                             LEP39120
      SM0=0.5*SMU/(8.*(3.-FLOAT(KPLANE)))
      DO 100 IW=1,2                                                     LEP39130
      LORKW=LW                                                          LEP39140
      KORLW=KW                                                          LEP39150
      JLKW=JLW                                                          LEP39160
      KLORLL=KAL                                                        LEP39170
      KUORLU=KU                                                         LEP39180
      LMORKM=LM                                                         LEP39190
      KORLMX=KMAX                                                       LEP39200
      LKMXBC=LMAXBC                                                     LEP39210
      LK1BC=L1BC                                                        LEP39220
      JLK1WL=JL1WL                                                      LEP39230
      JLK1WU=JL1WU                                                      LEP39240
      L1=1                                                              LEP39250
      K1=0                                                              LEP39260
      IF (IW.EQ.1) GO TO 10                                             LEP39270
      IF (KPLANE.EQ.1) GO TO 100                                        LEP39280
      JLKW=JKW                                                          LEP39290
      LORKW=KW                                                          LEP39300
      KORLW=LW                                                          LEP39310
      KLORLL=LL                                                         LEP39320
      KUORLU=LU                                                         LEP39330
      LMORKM=KM                                                         LEP39340
      KORLMX=LMAX                                                       LEP39350
      LKMXBC=KMAXBC                                                     LEP39360
      LK1BC=K1BC                                                        LEP39370
      JLK1WL=JK1WL                                                      LEP39380
      JLK1WU=JK1WU                                                      LEP39390
      L1=0                                                              LEP39400
      K1=1                                                              LEP39410
   10 CONTINUE                                                          LEP39420
      J=JJ                                                              LEP39430
      KLXP=KORLMX                                                       LEP39440
      IF(KORLW.GT.0) KLXP=KORLW                                         LEP39450
      DO 95 KORL=KLORLL,KUORLU
      IF(LORKW) 11,11,12
   11 M2=1
      LK1=2
      LK2=LMORKM
      GO TO 15
   12 IF(KORL.GT.KLXP.OR.J.GE.JLKW) GO TO 11
      M2=2
      LK1=2
      LK2=LORKW-1
   15 DO 95 M=1,M2                                                      LEP39540
      IF (M-2) 25,20,25                                                 LEP39550
   20 LK1=LORKW+2                                                       LEP39560
      LK2=LMORKM                                                        LEP39570
      NSYML=0                                                           LEP39580
      GO TO 30                                                          LEP39590
   25 NSYML=0                                                           LEP39600
C  TEST FOR LOWER SYMMETRY PLANE                                        LEP39610
      IF(LK1BC.EQ.1.AND.(J.LT.JLK1WL.OR.J.GT.JLK1WU.OR.KORL.GT.KLXP))   LEP39620
     1   NSYML=5-IW                                                     LEP39630
C  TEST FOR UPPER SYMMETRY PLANE                                        LEP39640
   30 NSYMU=0                                                           LEP39650
      IF(LK2.EQ.LMORKM.AND.(LKMXBC.EQ.3.OR.LKMXBC.EQ.4)) NSYMU = LKMXBC LEP39660
      DO 35 N=1,5                                                       LEP39670
   35 CDM(N)=0.0                                                        LEP39680
      SM1=0.0                                                           LEP39690
      DO 40 LORK=LK1,LK2                                                LEP39700
      L=LORK                                                            LEP39710
      K=KORL                                                            LEP39720
      IF(IW.EQ.2) L=KORL                                                LEP39730
      IF(IW.EQ.2) K=LORK                                                LEP39740
   40 SM1=AMAX1(SM1,ABS((Q6(L+L1,K+K1)-Q6(L-L1,K-K1))/Q6(L,K)))         LEP39750
      SM1=SM0/(1.0+0.25*SM1)                                            LEP39760
      LK2M=LK2-1                                                        LEP39770
      IF(LAXIS.NE.1) GO TO 41                                           LEP39780
      IF(LK1.EQ.2.AND.IW.EQ.1) GO TO 42                                 LEP39790
   41 IF (LK1.GT.2.OR.NSYML.EQ.0) GO TO 60                              LEP39800
C  SMOOTHING AT LOWER SYMMETRY PLANE OR SYMMETRY AXIS                   LEP39810
   42 L=1                                                               LEP39820
      K=KORL                                                            LEP39830
      IF(IW.EQ.2) L=KORL                                                LEP39840
      IF(IW.EQ.2) K=1                                                   LEP39850
      CJ=Q6(L+L1,K+K1) + Q6(L,K)                                        LEP39860
      DO 55 N=1,5                                                       LEP39870
      IF(LAXIS) 658,658,656                                             LEP39880
  656 IF(IW.NE.1) GO TO 658                                             LEP39890
      IF(LK1-2)658,657,658                                              LEP39900
C     SMOOTHING AT SYMMETRY AXIS                                        LEP39910
  657 IF(N.EQ.3 .OR. N.EQ.4) GO TO 45                                   LEP39920
      GO TO 50                                                          LEP39930
  658 IF (N-NSYML) 50,45,50                                             LEP39940
   45 S(L,N+8,K)=S(L,N+8,K)-6.0*SM1*CJ*Q(L,N,K)                         LEP39950
      CDM(N)=CJ*(Q(L+2*L1,N,K+2*K1)+Q(L,N,K)+                           LEP39960
     1  2.*(Q(L,N,K)-Q(L+L1,N,K+K1)))                                   LEP39970
      GO TO 55                                                          LEP39980
   50 CDM(N)=CJ*(Q(L+2*L1,N,K+2*K1)-Q(L+L1,N,K+K1)                      LEP39990
     1+3.*(Q(L,N,K)-Q(L+L1,N,K+K1)))                                    LEP40000
      S(L,N+8,K)=S(L,N+8,K)-2.0*SM1*CDM(N)                              LEP40010
   55 CONTINUE                                                          LEP40020
   60 CONTINUE                                                          LEP40030
      DO 65 LORK=LK1,LK2M                                               LEP40040
      L=LORK                                                            LEP40050
      K=KORL                                                            LEP40060
      IF(IW.EQ.2) L=KORL                                                LEP40070
      IF(IW.EQ.2) K=LORK                                                LEP40080
      CJ=Q6(L+L1,K+K1)+Q6(L,K)                                          LEP40090
      DO 65 N=1,5                                                       LEP40100
      CDKLN=CJ*(Q(L+2*L1,N,K+2*K1)-3.0*(Q(L+L1,N,K+K1)                  LEP40110
     1 -Q(L,N,K))-Q(L-L1,N,K-K1))                                       LEP40120
      S(L,N+8,K)=S(L,N+8,K)-SM1*(CDKLN-CDM(N))                          LEP40130
      CDM(N)=CDKLN                                                      LEP40140
   65 CONTINUE                                                          LEP40150
      L=LK2                                                             LEP40160
      K=KORL                                                            LEP40170
      IF(IW.EQ.2) L=KORL                                                LEP40180
      IF(IW.EQ.2) K=LK2                                                 LEP40190
      CJ=Q6(L+L1,K+K1)+Q6(L,K)                                          LEP40200
      DO 90 N=1,5                                                       LEP40210
      IF (NSYMU) 75,70,75                                               LEP40220
   70 S(L,N+8,K)=S(L,N+8,K)+SM1*CDM(N)                                  LEP40230
      GO TO 90                                                          LEP40240
C  SMOOTHING AT UPPER SYMMETRY PLANE                                    LEP40250
   75 IF (N-NSYMU) 85,80,85                                             LEP40260
   80 S(L+L1,N+8,K+K1)=S(L+L1,N+8,K+K1)-6.0*SM1*CJ*Q(L+L1,N,K+K1)       LEP40270
      CDKLN=CJ*(-(Q(L+L1,N,K+K1)+Q(L-L1,N,K-K1))                        LEP40280
     1+2.*(Q(L,N,K)-Q(L+L1,N,K+K1)))                                    LEP40290
      S(L,N+8,K)=S(L,N+8,K)-SM1*(CDKLN-CDM(N))                          LEP40300
      GO TO 90                                                          LEP40310
   85 CDKLN=CJ*(Q(L,N,K)-Q(L-L1,N,K-K1)+3.*                             LEP40320
     1(Q(L,N,K)-Q(L+L1,N,K+K1)))                                        LEP40330
      S(L,N+8,K)=S(L,N+8,K)-SM1*(CDKLN-CDM(N))                          LEP40340
      S(L+L1,N+8,K+K1)=S(L+L1,N+8,K+K1)+2.0*SM1*CDKLN                   LEP40350
   90 CONTINUE                                                          LEP40360
   95 CONTINUE                                                          LEP40370
  100 CONTINUE                                                          LEP40380
      RETURN                                                            LEP40390
      END                                                               LEP40400
*DECK SMOTHJ                                                            LEP40410
      SUBROUTINE SMOTHJ(L)                                              LEP40420
*CALL BASE                                                              LEP40430
*CALL VARS1                                                             LEP40440
*CALL VARS2                                                             LEP40450
      DIMENSION CDM(5)                                                  LEP40460
C     GLOBALLY FULLY CONSERVATIVE SMOOTHING                             LEP40470
      JMM=JM-1                                                          LEP40480
                                                                        LEP40490
C     XI DIRECTION                                                      LEP40500
      DO 100 N=1,5                                                      LEP40510
  100 CDM(N)=0.0                                                        LEP40520
      SM1=0.0                                                           LEP40530
      DO 150 J=2,JM                                                     LEP40540
  150 SM1=AMAX1(SM1,ABS((Q6(L,J+1)-Q6(L,J-1))/Q6(L,J)))                 LEP40550
      SM1=SM0/(1.0+0.25*SM1)                                            LEP40560
      DO 200 J=2,JMM                                                    LEP40570
      CJ=Q6(L,J+1)+Q6(L,J)                                              LEP40580
      DO 200 N=1,5                                                      LEP40590
      CDJN=CJ*(Q(L,N,J+2)-3.0*(Q(L,N,J+1)                               LEP40600
     1                    -Q(L,N,J))-Q(L,N,J-1))                        LEP40610
      S(L,N+8,J)=S(L,N+8,J)-SM1*(CDJN-CDM(N))                           LEP40620
      CDM(N)=CDJN                                                       LEP40630
  200 CONTINUE                                                          LEP40640
      DO 300 N=1,5                                                      LEP40650
  300 S(L,N+8,JM)=S(L,N+8,JM)+SM1*CDM(N)                                LEP40660
      RETURN                                                            LEP40670
      END                                                               LEP40680
*DECK STEP                                                              LEP40690
      SUBROUTINE STEP(DQ0QMX,IDTSW)
*CALL BASE                                                              LEP40710
*CALL VARS1                                                             LEP40720
*CALL SHOCKC                                                            LEP40730
*CALL BTRID                                                             LEP40740
*CALL GLOB                                                              LEP40750
      COMMON/FILTR/INFLT                                                LEP40760
*CALL VARS2                                                             LEP40770
      DIMENSION DINTGL(5)                                               LEP40780
C                                                                       LEP40790
      JT=1                                                              LEP40800
      KT=1                                                              LEP40810
      LT=1                                                              LEP40820
      SIGMAX=0.0                                                        LEP40830
      JTJ=1                                                             LEP40840
      KTJ=1                                                             LEP40850
      LTJ=1                                                             LEP40860
      SIGJMX=0.0                                                        LEP40870
C     CALL SHOCK                                                        LEP40880
C                                                                       LEP40890
C     J SWEEP ALONG (K,L) LINES                                         LEP40900
      VOL=0.                                                            LEP40910
      RESM=0.                                                           LEP40920
      RESID=0.0                                                         LEP40930
      K1=2                                                              LEP40940
      K2=KM                                                             LEP40950
      JMH= JM-1                                                         LEP40960
      KMH= KM-1                                                         LEP40970
      LMH= LM-1                                                         LEP40980
      IF (KPLANE.EQ.0) GO TO 10                                         LEP40990
      K1=KAL                                                            LEP41000
      K2=KU                                                             LEP41010
      KMH=1                                                             LEP41020
   10 CONTINUE                                                          LEP41030
      DO 65 K=1,KMAX                                                    LEP41040
      CALL LJPIO(K,2)                                                   LEP41050
      DO 15 L=1,LMAX                                                    LEP41060
      DO 15 J=1,JMAX                                                    LEP41070
      Q6(L,J)=Q(L,15,J)                                                 LEP41080
      DXIDY(L,15,J)=0.                                                  LEP41090
      DXIDZ(L,16,J)=0.                                                  LEP41100
   15 CONTINUE                                                          LEP41110
      DO 60 L=LL,LU                                                     LEP41120
      DO 20 J=1,JMAX                                                    LEP41130
      CALL DJMET(J,L,XX(J,1),XX(J,2),XX(J,3))                           LEP41140
   20 CONTINUE                                                          LEP41150
      IF (K.LT.KAL.OR.K.GT.KU) GO TO 50                                 LEP41160
      IF(IGNCAL.GE.2) CALL EIGENJ(K,L)                                  LEP41170
      CALL RHSJ(L)                                                      LEP41180
      CALL SMOTHJ(L)                                                    LEP41190
      IF (K.LT.K1.OR.K.GT.K2) GO TO 35                                  LEP41200
      IF (L.LT.2.OR.L.GT.LM) GO TO 35                                   LEP41210
      DO 30 J=2,JM                                                      LEP41220
      DO 30 N=1,5                                                       LEP41230
      DVOL=1.0/Q6(L,J)                                                  LEP41240
      VOL= VOL+DVOL                                                     LEP41250
      RES=ABS(S(L,N+8,J))                                               LEP41260
      IF (RES-RESM) 30,30,25                                            LEP41270
   25 RESM=RES                                                          LEP41280
      JRESM=J                                                           LEP41290
      KRESM=K                                                           LEP41300
      LRESM=L                                                           LEP41310
      NRESM=N                                                           LEP41320
   30 RESID=RESID+RES**2                                                LEP41330
   35 CALL FILTRX(K,L,1,JMAX)                                           LEP41340
      IF(J1BC.NE.0) CALL BCXIN(L)                                       LEP41350
      CALL BCXOUT(L)                                                    LEP41360
      IF(J1BC.NE.0) CALL BCJMAT(1,K,L,1)                                LEP41370
      IF(JMAXBC.EQ.2) CALL BCJMAT(JMAX,K,L,1)                           LEP41380
      CALL BCALJ(K,L)                                                   LEP41390
C  S MUST BE ZERO ON B.C.                                               LEP41400
      CALL BTRI(JB,JMAX)                                                LEP41410
      DO 45 J=JB,JMAX                                                   LEP41420
      DO 45 N=1,5                                                       LEP41430
   45 S(L,N+8,J) = F(J,N)*Q6(L,J)                                       LEP41440
C     PUT XXI,YXI,ZXI ONTO DISC FOR K & L SWEEPS BELOW                  LEP41450
   50 DO 55 J=1,JMAX                                                    LEP41460
      Q(L,14,J)=Q6(L,J)                                                 LEP41470
      YXI(L,15,J)=XX(J,2)                                               LEP41480
   55 ZXI(L,16,J)=XX(J,3)                                               LEP41490
   60 CONTINUE                                                          LEP41500
      CALL LJPIO(K,1)                                                   LEP41510
   65 CONTINUE                                                          LEP41520
      RESID = SQRT(RESID)/(DT+.00005)/(JMH*KMH*LMH*5.0)                 LEP41530
      NCM=NC-1                                                          LEP41540
      WRITE (6,70)NCM,RESID,RESM,JRESM,KRESM,LRESM,NRESM                LEP41550
      PRINT 70,NCM,RESID,RESM,JRESM,KRESM,LRESM,NRESM                   LEP41560
   70 FORMAT(1H0,2HN=,I4,1X,9HL2 RESID=,1PE10.3,11H MAX RESID=,         LEP41570
     1  1PE10.3,9H J,K,L,N=,I2,3(1H,,I2))                               LEP41580
      IF (RESID.LT.1.) GO TO 80                                         LEP41590
      WRITE (6,75)                                                      LEP41600
   75 FORMAT(41H ****STOPPING**RESIDUAL IS GREATER THAN 1  )            LEP41610
      CALL OUTALL(NC)                                                   LEP41620
      GO TO 190                                                         LEP41630
   80 CONTINUE                                                          LEP41640
C                                                                       LEP41650
C                                                                       LEP41660
C                                                                       LEP41670
C     K SWEEP ALONG (J,L) LINES                                         LEP41680
      DQ0QMX=0.                                                         LEP41690
      RUMAX=0.
      DO 180 J=1,JMAX                                                   LEP41700
      CALL LKPIO(J,2)                                                   LEP41710
C     SET UP TO AVOID DQ0Q FOR N=2 IN SEPARATED REQIONS
C
      IF(KPLANE.EQ.1) GO TO 84
      DO 83 L=LL,LU
      DO 83 K=KAL,KU
      IF(Q(L,2,K).LE.RUMAX) GO TO 83
      RUMAX=Q(L,2,K)
   83 CONTINUE
   84 CONTINUE
      CALL DJMET2(J,L,XJ)                                               LEP41720
      DO 85 L=1,LMAX                                                    LEP41730
      DO 85 K=1,KMAX                                                    LEP41740
      Q6(L,K)=Q(L,14,K)                                                 LEP41750
      XXI(L,14,K)=XJ                                                    LEP41760
   85 CONTINUE                                                          LEP41770
      IF (J.LT.JB) GO TO 165                                            LEP41780
      IF(IGNCAL.GE.2) CALL EIGEN(J)                                     LEP41790
      IF (KPLANE.EQ.1) GO TO 120                                        LEP41800
      DO 115 L=LL,LU                                                    LEP41810
         CALL FILTRY(J,L,1,KMAX)                                        LEP41820
      CALL BCLK1(2,J,L)                                                 LEP41830
      CALL BCLKMX(2,J,L)                                                LEP41840
      IF(INVISC.EQ.0) CALL VISMAT(2,J,L)                                LEP41850
      IF (J.EQ.1.AND.J1BC.NE.0) GO TO 90                                LEP41860
      IF (J.EQ.JMAX.AND.JMAXBC.EQ.2) GO TO 90                           LEP41870
      GO TO 100                                                         LEP41880
   90 DO 95 K=KAL,KU                                                    LEP41890
   95 CALL BCJMAT(J,K,L,2)                                              LEP41900
  100 CONTINUE                                                          LEP41910
      CALL BCALKL(J,L,1)                                                LEP41920
         CALL BTRI(KAL,KU)                                              LEP41930
      IF(J*J1BC.EQ.1.AND.INFLT.EQ.1) CALL INFLTR(2,L)                   LEP41940
      DO 110 N=1,5                                                      LEP41950
      DO 110 K=KAL,KU                                                   LEP41960
  110    S(L,N+8,K) = F(K,N)*Q6(L,K)                                    LEP41970
  115    CONTINUE                                                       LEP41980
C                                                                       LEP41990
C                                                                       LEP42000
C     L SWEEP ALONG J,K LINES                                           LEP42010
  120 R0 = -HDZ                                                         LEP42020
      DO 160 K=KAL,KU                                                   LEP42030
            CALL FILTRZ(J,K,1,LMAX)                                     LEP42040
      CALL BCLK1(1,J,K)                                                 LEP42050
      CALL BCLKMX(1,J,K)                                                LEP42060
      IF(INVISC.EQ.0) CALL VISMAT(1,J,K)                                LEP42070
      IF (J.EQ.1.AND.J1BC.NE.0) GO TO 125                               LEP42080
      IF (J.EQ.JMAX.AND.JMAXBC.EQ.2) GO TO 125                          LEP42090
      GO TO 135                                                         LEP42100
  125 DO 130 L=LL,LU                                                    LEP42110
  130 CALL BCJMAT(J,K,L,3)                                              LEP42120
  135 CONTINUE                                                          LEP42130
      CALL BCALKL(J,K,2)                                                LEP42140
            CALL BTRI(LL,LU)                                            LEP42150
      IF(J*J1BC.EQ.1.AND.INFLT.EQ.1) CALL INFLTR(3,K)                   LEP42160
      DO 155 L=LL,LU                                                    LEP42170
      DO 150 N=1,5                                                      LEP42180
      IF (N.EQ.3.OR.N.EQ.4) GO TO 145                                   LEP42190
      IF (N.EQ.2.AND.(ABS(Q(L,2,K)).LT.0.01*RUMAX)) GO TO 145
      IF (Q(L,N,K).EQ.0.) GO TO 145                                     LEP42200
      DQ0Q=F(L,N)/Q(L,N,K)                                              LEP42210
      IF (ABS(DQ0Q).LE.ABS(DQ0QMX)) GO TO 145                           LEP42220
      DQ0QMX=DQ0Q                                                       LEP42230
      JDQ=J                                                             LEP42240
      KDQ=K                                                             LEP42250
      LDQ=L                                                             LEP42260
      NDQ=N                                                             LEP42270
  145 CONTINUE                                                          LEP42280
  150 Q(L,N,K) = F(L,N) + Q(L,N,K)                                      LEP42290
  155 CONTINUE                                                          LEP42300
  160       CONTINUE                                                    LEP42310
C                                                                       LEP42320
  165 CALL BC(J)
      CALL GLOBL(J)                                                     LEP42340
      IF (J.NE.JTT) GO TO 170                                           LEP42350
C     NOZZLE DISCHARGE COEFFICIENT CW                                   LEP42360
C     INTEGRATE MASS FLOW AT THROAT J=JT                                LEP42370
      NMX=1                                                             LEP42380
      L1=1                                                              LEP42390
      L2=LMAX                                                           LEP42400
      IF(LW.GT.0) L2=LW                                                 LEP42410
      K1=1                                                              LEP42420
      K2=KMAX                                                           LEP42430
      IF(KW.GT.0) K2=KW                                                 LEP42440
      CALL GDINTF(J,K1,K2,L1,L2,NMX,DINTGL)                             LEP42450
      CW=DINTGL(1)/(CWFAC*AT)                                           LEP42460
  170 CONTINUE                                                          LEP42470
      IF(IDTSW.EQ.0) GO TO 172
      CALL DTSW(1)
  172 CALL PRECAL(J)                                                    LEP42480
      DO 175 L=1,LMAX                                                   LEP42490
      DO 175 K=1,KMAX                                                   LEP42500
      Q(L,15,K)=Q6(L,K)                                                 LEP42510
  175 CONTINUE                                                          LEP42520
      CALL LKPIO(J,1)                                                   LEP42530
C     SWITCH DT BACK, IF NECESSARY
      IF(IDTSW.EQ.0) GO TO 180
      CALL DTSW(2)
  180 CONTINUE                                                          LEP42540
C                                                                       LEP42550
      TAU = TAU + DT                                                    LEP42560
      WRITE (6,185)NC,TAU,DT,DQ0QMX,JDQ,KDQ,LDQ,NDQ                     LEP42570
  185 FORMAT(1H0,5X,4H NC=,I3,6H TIME=,F10.4,4H DT=,E11.4,              LEP42580
     1  1X,17HMAXIMUM DELTAQ/Q=,1PE10.3,11HAT J,K,L,N=I2,3(1H,,I2))     LEP42590
      IF(NK.EQ.0.AND.RESIDS.LT.RESID) NRES=2*NRES                       LEP42600
      IF(NSTEP.EQ.2) RESIDS=RESID                                       LEP42610
C     SWITCH DT FOR NEXT STEP IF IDTSW.NE.0
      IF(IDTSW.NE.0) CALL DTSW(1)
      RETURN                                                            LEP42620
C                                                                       LEP42630
C     ERROR STOP WHEN RESIDUAL  > 1                                     LEP42640
  190 STOP                                                              LEP42650
      END                                                               LEP42660
*DECK SW                                                                LEP42670
      SUBROUTINE SW                                                     LEP42680
*CALL RHSBCC                                                            LEP42690
*CALL BASE                                                              LEP42700
      IF(IW.EQ.2) GO TO 100                                             LEP42710
      LORKMX=LMAX                                                       LEP42720
      KORLMX=KMAX                                                       LEP42730
      LMORKM=LM                                                         LEP42740
      LLORKL=LL                                                         LEP42750
      LUORKU=LU                                                         LEP42760
      KLORLL=KAL                                                        LEP42770
      KUORLU=KU                                                         LEP42780
      LKMXBC=LMAXBC                                                     LEP42790
      KLMXBC=KMAXBC                                                     LEP42800
      LK1BC=L1BC                                                        LEP42810
      KL1BC=K1BC                                                        LEP42820
      LORKW=LW                                                          LEP42830
      KORLW=KW                                                          LEP42840
      JLKW=JLW                                                          LEP42850
      JKLW=JKW                                                          LEP42860
      JLK1WL=JL1WL                                                      LEP42870
      JLK1WU=JL1WU                                                      LEP42880
      JKL1WL=JK1WL                                                      LEP42890
      JKL1WU=JK1WU                                                      LEP42900
      DZORDY=DZ1                                                        LEP42910
      RETURN                                                            LEP42920
  100 LORKMX=KMAX                                                       LEP42930
      KORLMX=LMAX                                                       LEP42940
      LMORKM=KM                                                         LEP42950
      LLORKL=KAL                                                        LEP42960
      LUORKU=KU                                                         LEP42970
      KLORLL=LL                                                         LEP42980
      KUORLU=LU                                                         LEP42990
      LKMXBC=KMAXBC                                                     LEP43000
      KLMXBC=LMAXBC                                                     LEP43010
      LK1BC=K1BC                                                        LEP43020
      KL1BC=L1BC                                                        LEP43030
      KORLW=LW                                                          LEP43040
      LORKW=KW                                                          LEP43050
      JLKW=JKW                                                          LEP43060
      JKLW=JLW                                                          LEP43070
      JKL1WL=JL1WL                                                      LEP43080
      JKL1WU=JL1WU                                                      LEP43090
      JLK1WL=JK1WL                                                      LEP43100
      JLK1WU=JK1WU                                                      LEP43110
      DZORDY=DY1                                                        LEP43120
      RETURN                                                            LEP43130
      END                                                               LEP43140
*DECK VISCOF                                                            LEP43150
      SUBROUTINE VISCOF(TEMP,RMUE)                                      LEP43160
*CALL VISCO                                                             LEP43170
C                                                                       LEP43180
C     DIMENSIONLESS LAMINAR VISCOSITY COEFFICIENT RMUE IS EVALUATED     LEP43190
C     FROM SUTHERLAND LAW WHEN ISUTH=1, AND FROM POWER LAW WHEN ISUTH=0 LEP43200
C                                                                       LEP43210
      IF(ISUTH-1) 20,10,30                                              LEP43220
C     SUTHERLAND LAW                                                    LEP43230
   10 RMUE= (TEMP**1.5)/(TEMP+TSUTH)                                    LEP43240
      RETURN                                                            LEP43250
C     POWER LAW                                                         LEP43260
   20 RMUE=TEMP**RMUEXP                                                 LEP43270
      RETURN                                                            LEP43280
   30 CONTINUE                                                          LEP43290
      RETURN                                                            LEP43300
      END                                                               LEP43310
*DECK VISMAT                                                            LEP43320
      SUBROUTINE VISMAT(IWW,JJ,K)                                       LEP43330
*CALL BASE                                                              LEP43340
*CALL VARS1                                                             LEP43350
*CALL BTRID                                                             LEP43360
*CALL RHSBCC                                                            LEP43370
*CALL VISC                                                              LEP43380
*CALL VARS2                                                             LEP43390
C     JACOBIAN MATRICES FOR VISCOUS TERMS THAT ARE TREATED IMPLICITLY   LEP43400
      IW=IWW                                                            LEP43410
      J=JJ                                                              LEP43420
      CALL SW                                                           LEP43430
      GKPR = GAMMA/PR                                                   LEP43440
      PRTR = PR/0.9                                                     LEP43450
      DRE = -HD/(RE*DZORDY**2)                                          LEP43460
      IF (IW.EQ.2) GO TO 10                                             LEP43470
      CALL ZZM(J,K,1,LMAX)                                              LEP43480
      GO TO 20                                                          LEP43490
   10 CALL YYM(J,K,1,KMAX)                                              LEP43500
      DO 15 N=1,4                                                       LEP43510
      DO 15 L=1,KMAX                                                    LEP43520
   15 ZZ(L,N)=YY(L,N)                                                   LEP43530
   20 R3 = 1./3.                                                        LEP43540
      DO 25 L=1,LORKMX                                                  LEP43550
      LLL=L                                                             LEP43560
      KKK=K                                                             LEP43570
      IF(IW.EQ.2) LLL=K                                                 LEP43580
      IF(IW.EQ.2) KKK=L                                                 LEP43590
      RR(L) = 1./Q(LLL,1,KKK)                                           LEP43600
      Q2=(Q(LLL,2,KKK)**2+Q(LLL,3,KKK)**2+Q(LLL,4,KKK)**2)*RR(L)        LEP43610
      T = GD*(Q(LLL,5,KKK) - 0.5*Q2)*RR(L)                              LEP43620
      CALL VISCOF(T,RMUE)                                               LEP43630
      VNU = RMUE+TURMU(LLL,6,KKK)                                       LEP43640
      GKAP = RMUE+PRTR*TURMU(LLL,6,KKK)                                 LEP43650
      RJ = 1./Q6(LLL,KKK)                                               LEP43660
      S0(L) = (ZZ(L,1)**2+ZZ(L,2)**2+ZZ(L,3)**2)*RJ                     LEP43670
      S1(L) = (S0(L)+R3*ZZ(L,1)**2*RJ)*VNU                              LEP43680
      S2(L) = (S0(L)+R3*ZZ(L,2)**2*RJ)*VNU                              LEP43690
      S3(L) = (S0(L)+R3*ZZ(L,3)**2*RJ)*VNU                              LEP43700
      S4(L) = R3*ZZ(L,1)*ZZ(L,2)*RJ*VNU                                 LEP43710
      S5(L) = R3*ZZ(L,1)*ZZ(L,3)*RJ*VNU                                 LEP43720
      S6(L) = R3*ZZ(L,2)*ZZ(L,3)*RJ*VNU                                 LEP43730
      S0(L) = S0(L)*GKPR*GKAP                                           LEP43740
      RR(L) = 1./Q(LLL,1,KKK)                                           LEP43750
      U(L) = Q(LLL,2,KKK)*RR(L)                                         LEP43760
      V(L) = Q(LLL,3,KKK)*RR(L)                                         LEP43770
      W(L) = Q(LLL,4,KKK)*RR(L)                                         LEP43780
      E(L) = Q(LLL,5,KKK)*RR(L)                                         LEP43790
   25 CONTINUE                                                          LEP43800
      DO 30 L=2,LORKMX                                                  LEP43810
      LR = L-1                                                          LEP43820
      C0 = S0(L)+S0(LR)                                                 LEP43830
      C1 = S1(L)+S1(LR)                                                 LEP43840
      C2 = S2(L)+S2(LR)                                                 LEP43850
      C3 = S3(L)+S3(LR)                                                 LEP43860
      C4 = S4(L)+S4(LR)                                                 LEP43870
      C5 = S5(L)+S5(LR)                                                 LEP43880
      C6 = S6(L)+S6(LR)                                                 LEP43890
      D(L,2,1) =  -(C1*U(LR)+C4*V(LR)+C5*W(LR))*RR(LR)                  LEP43900
      DEU(L,2,1)=  -(C1*U(L )+C4*V(L )+C5*W(L ))*RR(L )                 LEP43910
      D(L,2,2) =  C1*RR(LR)                                             LEP43920
      DEU(L,2,2) = C1*RR(L)                                             LEP43930
      D(L,2,3) = C4*RR(LR)                                              LEP43940
      DEU(L,2,3) = C4*RR(L)                                             LEP43950
      D(L,2,4) = C5*RR(LR)                                              LEP43960
      DEU(L,2,4) = C5*RR(L)                                             LEP43970
      D(L,2,5) = 0.0                                                    LEP43980
      DEU(L,2,5) = 0.0                                                  LEP43990
      D(L,3,1) = -(C2*V(LR)+C4*U(LR)+C6*W(LR))*RR(LR)                   LEP44000
      DEU(L,3,1)= -(C2*V(L )+C4*U(L )+C6*W(L ))*RR(L )                  LEP44010
      D(L,3,2) = C4*RR(LR)                                              LEP44020
      DEU(L,3,2) = C4*RR(L)                                             LEP44030
      D(L,3,3) = C2*RR(LR)                                              LEP44040
      DEU(L,3,3) = C2*RR(L)                                             LEP44050
      D(L,3,4) = C6*RR(LR)                                              LEP44060
      DEU(L,3,4) = C6*RR(L)                                             LEP44070
      D(L,3,5) = 0.0                                                    LEP44080
      DEU(L,3,5) = 0.0                                                  LEP44090
      D(L,4,1) = -(C3*W(LR)+C5*U(LR)+C6*V(LR))*RR(LR)                   LEP44100
      DEU(L,4,1) =-(C3*W(L )+C5*U(L )+C6*V(L ))*RR(L )                  LEP44110
      D(L,4,2) = C5*RR(LR)                                              LEP44120
      DEU(L,4,2) = C5*RR(L)                                             LEP44130
      D(L,4,3) = C6*RR(LR)                                              LEP44140
      DEU(L,4,3) = C6*RR(L)                                             LEP44150
      D(L,4,4) = C3*RR(LR)                                              LEP44160
      DEU(L,4,4) = C3*RR(L)                                             LEP44170
      D(L,4,5) = 0.0                                                    LEP44180
      DEU(L,4,5) = 0.0                                                  LEP44190
      D(L,5,1) = -((C1-C0)*U(LR)**2+(C2-C0)*V(LR)**2+(C3-C0)*W(LR)**2   LEP44200
     1  +2.*C4*U(LR)*V(LR)+2.*C5*U(LR)*W(LR)+2.*C6*V(LR)*W(LR)+C0*E(LR))LEP44210
     2  *RR(LR)                                                         LEP44220
      DEU(L,5,1) = -((C1-C0)*U(L)**2+(C2-C0)*V(L)**2+(C3-C0)*W(L)**2+   LEP44230
     1  2.*C4*U(L)*V(L)+2.*C5*U(L)*W(L)+2.*C6*V(L)*W(L)+C0*E(L))*RR(L)  LEP44240
      D(L,5,2) = ((C1-C0)*U(LR)+C4*V(LR)+C5*W(LR))*RR(LR)               LEP44250
      DEU(L,5,2)= ((C1-C0)*U(L )+C4*V(L )+C5*W(L ))*RR(L )              LEP44260
      D(L,5,3) = ((C2-C0)*V(LR)+C4*U(LR)+C6*W(LR))*RR(LR)               LEP44270
      DEU(L,5,3)= ((C2-C0)*V(L )+C4*U(L )+C6*W(L ))*RR(L )              LEP44280
      D(L,5,4) = ((C3-C0)*W(LR)+C5*U(LR)+C6*V(LR))*RR(LR)               LEP44290
      DEU(L,5,4) = ((C3-C0)*W(L)+C5*U(L)+C6*V(L))*RR(L)                 LEP44300
      D(L,5,5) = C0*RR(LR)                                              LEP44310
      DEU(L,5,5) = C0*RR(L)                                             LEP44320
   30 CONTINUE                                                          LEP44330
C     TEST FOR INTERMEDIATE WALL                                        LEP44340
      INTWAL=0                                                          LEP44350
      IF(LORKW.GT.0.AND.J.LE.JLKW) INTWAL=1                             LEP44360
      IF(KORLW.GT.0.AND.K.GE.KORLW+1) INTWAL=0                          LEP44370
      DO 40 L=2,LMORKM                                                  LEP44380
      LR = L+1                                                          LEP44390
      DO 35 N=2,5                                                       LEP44400
      DO 35 M=1,5                                                       LEP44410
      IF (INTWAL.EQ.1.AND.(L.EQ.LORKW.OR.L.EQ.LORKW+1)) GO TO 35        LEP44420
      A(L,N,M) = A(L,N,M)+DRE*D(L,N,M)                                  LEP44430
      B(L,N,M) = B(L,N,M)-DRE*(D(LR,N,M)+DEU(L,N,M))                    LEP44440
      C(L,N,M) = C(L,N,M)+DRE*DEU(LR,N,M)                               LEP44450
   35 CONTINUE                                                          LEP44460
   40 CONTINUE                                                          LEP44470
C     IMPLICIT VISCOUS BLOCKS FOR INTERMEDIATE WALL                     LEP44480
      IF (INTWAL.EQ.0) GO TO 50                                         LEP44490
      L=LORKW                                                           LEP44500
      LR=LORKW+1                                                        LEP44510
      DO 45 N=2,5                                                       LEP44520
      DO 45 M=1,5                                                       LEP44530
      A(L,N,M)=A(L,N,M)+2.0*DRE*D(L,N,M)                                LEP44540
      B(L,N,M)=B(L,N,M)-2.0*DRE*DEU(L,N,M)                              LEP44550
      C(L,N,M)=0.0                                                      LEP44560
      A(LR,N,M)=0.0                                                     LEP44570
      B(LR,N,M)=B(LR,N,M)-2.0*DRE*D(LR+1,N,M)                           LEP44580
   45 C(LR,N,M)=C(LR,N,M)+2.0*DRE*DEU(LR+1,N,M)                         LEP44590
   50 CONTINUE                                                          LEP44600
C                                                                       LEP44610
C     FILL IN VISCOUS PORTION OF IMPLICIT COEFF. MATRIX FOR             LEP44620
C   IMPLICIT OUTFLOW B.C. AT L=LORKMX (LKMXBC=2 OR 5), OR FOR IMPLICIT  LEP44630
C   ADIABATIC WALL B.C. (LKMXBC=1), OR FOR SYMMETRY BC(LKMXBC=3,4).     LEP44640
C                                                                       LEP44650
      IF (LKMXBC.EQ.0) GO TO 65                                         LEP44660
      L=LORKMX                                                          LEP44670
      DO 60 N=2,5                                                       LEP44680
      IF (LKMXBC.LT.3.OR.LKMXBC.GT.4) GO TO 55                          LEP44690
      IF (N.EQ.LKMXBC) GO TO 65                                         LEP44700
   55 DO 60 M=1,5                                                       LEP44710
      A(L,N,M)=A(L,N,M) + (2.0*DRE)*D(L,N,M)                            LEP44720
      B(L,N,M)=B(L,N,M) - (2.0*DRE)*DEU(L,N,M)                          LEP44730
   60 CONTINUE                                                          LEP44740
   65 CONTINUE                                                          LEP44750
C                                                                       LEP44760
C     FILL IN VISCOUS PORTION OF IMPLICIT COEFF MATRIX FOR IMPLICIT     LEP44770
C     ADIABATIC WALL BC FOR JLK1WL.LE.J.LE.JLK1WU AND SYMMETRY BC       LEP44780
C     FOR J OUTSIDE THAT INTERVAL                                       LEP44790
      L=1                                                               LEP44800
      IF (LK1BC.NE.1) GO TO 100                                         LEP44810
      NSYM=10                                                           LEP44820
C     TEST FOR INTERMEDIATE WALL NORMAL TO L=1                          LEP44830
      IF (KORLW) 70,70,80                                               LEP44840
C     TEST FOR WALL AT L=1                                              LEP44850
   70 IF (JLK1WL.LE.J.AND.J.LE.JLK1WU) GO TO 85                         LEP44860
C     SYMMETRY                                                          LEP44870
   75 IF(IW.EQ.1) NSYM=4                                                LEP44880
      IF(IW.EQ.2) NSYM=3                                                LEP44890
      GO TO 85                                                          LEP44900
C     TEST FOR WALL AT L=1                                              LEP44910
   80 IF (K-KORLW) 70,70,75                                             LEP44920
   85 DO 95 N=2,5                                                       LEP44930
      IF (N.EQ.NSYM) GO TO 95                                           LEP44940
      DO 90 M=1,5                                                       LEP44950
      B(L,N,M)=B(L,N,M)-(2.0*DRE)*D(L+1,N,M)                            LEP44960
      C(L,N,M)=C(L,N,M)+(2.0*DRE)*DEU(L+1,N,M)                          LEP44970
   90 CONTINUE                                                          LEP44980
   95 CONTINUE                                                          LEP44990
  100 RETURN                                                            LEP45000
      END                                                               LEP45010
*DECK XXM                                                               LEP45020
      SUBROUTINE XXM(L,J,K1,K2)                                         LEP45030
*CALL BASE                                                              LEP45040
*CALL VARS1                                                             LEP45050
*CALL VARS2                                                             LEP45060
C                                                                       LEP45070
C  XI METRICS FORMED FOR A K,L LINE IN J                                LEP45080
C                                                                       LEP45090
C                                                                       LEP45100
C  SYMMETRY                                                             LEP45110
C                                                                       LEP45120
      DO 10 K=K1,K2                                                     LEP45130
      CALL DKMET(J,K,L,XK,YK,ZK)                                        LEP45140
      CALL DLMET(J,K,L,XL,YL,ZL)                                        LEP45150
      XX(K,1) = YK*ZL-ZK*YL                                             LEP45160
      XX(K,2) = ZK*XL-XK*ZL                                             LEP45170
      XX(K,3) = XK*YL-YK*XL                                             LEP45180
      XX(K,4) = 0.                                                      LEP45190
   10 CONTINUE                                                          LEP45200
      RETURN                                                            LEP45210
      END                                                               LEP45220
*DECK YYM                                                               LEP45230
      SUBROUTINE YYM(J,L,K1,K2)                                         LEP45240
*CALL BASE                                                              LEP45250
*CALL VARS1                                                             LEP45260
*CALL VARS2                                                             LEP45270
C                                                                       LEP45280
C  ETA METRICS FORMED FOR A J,L LINE IN K                               LEP45290
C                                                                       LEP45300
      DO 10 K = K1,K2                                                   LEP45310
      XJ=XXI(L,14,K)                                                    LEP45320
      YJ=YXI(L,15,K)                                                    LEP45330
      ZJ=ZXI(L,16,K)                                                    LEP45340
      CALL DLMET(J,K,L,XL,YL,ZL)                                        LEP45350
      YY(K,1) = ZJ*YL-YJ*ZL                                             LEP45360
      YY(K,2) = XJ*ZL-XL*ZJ                                             LEP45370
      YY(K,3) = YJ*XL-XJ*YL                                             LEP45380
      YY(K,4) = 0.                                                      LEP45390
   10 CONTINUE                                                          LEP45400
      RETURN                                                            LEP45410
      END                                                               LEP45420
*DECK ZERODQ                                                            LEP45430
      SUBROUTINE ZERODQ(I)                                              LEP45440
*CALL BASE                                                              LEP45450
*CALL VARS1                                                             LEP45460
*CALL BTRID                                                             LEP45470
*CALL VARS2                                                             LEP45480
C     DEFINE IMPLICIT OPERATOR MATRIX ELEMENTS TO YIELD DELTAQ=0        LEP45490
C     AT GRID POINTS WHERE LAGGED BOUNDARY CONDITIONS ARE TO BE USED    LEP45500
   15 DO 30 N=1,5                                                       LEP45510
      DO 20 M=1,5                                                       LEP45520
      A(I,N,M)=0.                                                       LEP45530
      B(I,N,M)=0.                                                       LEP45540
   20 C(I,N,M)=0.                                                       LEP45550
      B(I,N,N)=1.                                                       LEP45560
   30 F(I,N)=0.                                                         LEP45570
  100 CONTINUE                                                          LEP45580
      RETURN                                                            LEP45590
      END                                                               LEP45600
*DECK ZZM                                                               LEP45610
      SUBROUTINE ZZM(J,K,L1,L2)                                         LEP45620
*CALL BASE                                                              LEP45630
*CALL VARS1                                                             LEP45640
*CALL SHOCKC                                                            LEP45650
*CALL VARS2                                                             LEP45660
C                                                                       LEP45670
C  ZETA METRICS FORMED FOR A J,K LINE IN L                              LEP45680
C                                                                       LEP45690
C  SYMMETRY                                                             LEP45700
C                                                                       LEP45710
      DO 10 L = L1,L2                                                   LEP45720
      CALL DKMET(J,K,L,XK,YK,ZK)                                        LEP45730
C     CALL DJMET(J,L,XJ,YJ,ZJ)                                          LEP45740
      XJ=XXI(L,14,K)                                                    LEP45750
      YJ=YXI(L,15,K)                                                    LEP45760
      ZJ=ZXI(L,16,K)                                                    LEP45770
      ZZ(L,1) = YJ*ZK-ZJ*YK                                             LEP45780
      ZZ(L,2) = XK*ZJ-XJ*ZK                                             LEP45790
      ZZ(L,3) = XJ*YK-YJ*XK                                             LEP45800
      ZZ(L,4) = 0.                                                      LEP45810
   10 CONTINUE                                                          LEP45820
      RETURN                                                            LEP45830
      END                                                               LEP45840
*COMDECK    CARDS                                                       LEP45850
      COMMON /CARDS/                                                    LEP45860
     A    ITEMS,    ITPREC,   KCARDS,   KDOREC,   KIRECS,               LEP45870
     B    LASCOL,   LSOUGT,   LVJUMP,   L1SENT,   L2SENT,   NILERR,     LEP45880
     C    IREC,     IDAT                                                LEP45890
      INTEGER       IREC(200), IDAT(200)                                LEP45900
      REAL          REC(1)                                              LEP45910
      EQUIVALENCE   (IREC,REC)                                          LEP45920
*COMDECK    CDMERR                                                      LEP45930
      COMMON /CDMERR/                                                   LEP45940
     A    DMERCD,   DMERCM,   DMERLC,   DMERPM,   IOMERH,   IEHSAV      LEP45950
      INTEGER       DMERCD,   DMERCM,   DMERLC,   DMERPM                LEP45960
      COMMON /CDMETS/                                                   LEP45970
     A    TRARGS,   TROPID,   TRINST,   TRARGL,                         LEP45980
     B    TRSTSZ,   TRTOPM,   TRTOPS,   TRSTAK                          LEP45990
      INTEGER       TRARGS,   TROPID,   TRINST,   TRARGL(10)            LEP46000
      INTEGER       TRSTSZ,   TRTOPM,   TRTOPS,   TRSTAK(48)            LEP46010
*COMDECK    CDMERRA                                                     LEP46020
          USE /CDMERR/                                                  LEP46030
DMERCD    BSS       1                                                   LEP46040
DMERCM    BSS       1                                                   LEP46050
DMERLC    BSS       1                                                   LEP46060
DMERPM    BSS       1                                                   LEP46070
IOMERH    BSS       1                                                   LEP46080
IEHSAV    BSS       1                                                   LEP46090
          USE /CDMETS/                                                  LEP46100
TRARGS    BSS       1                                                   LEP46110
TROPID    BSS       1                                                   LEP46120
TRINST    BSS       1                                                   LEP46130
TRARGL    BSS       10                                                  LEP46140
TRSTSZ    BSS       1                                                   LEP46150
TRTOPM    BSS       1                                                   LEP46160
TRTOPS    BSS       1                                                   LEP46170
TRSTAK    BSS       48                                                  LEP46180
*COMDECK    CDMASTA                                                     LEP46190
          USE       /CDMAST/                                            LEP46200
MAXLDI    SET       16D                                                 LEP46210
ASTDIM    BSS       1                                                   LEP46220
          BSS       7              ASTOSD(1-7)                          LEP46230
SIZREC    BSS       1              RECORD SIZE IN WORDS (N)             LEP46240
RETCOD    BSS       1              RETURN CODE (BITS 0-8 OF FET+0)      LEP46250
EOFCOD    BSS       0                                                   LEP46260
EOICOD    BSS       1              END OF INFORMATION RETURN CODE       LEP46270
STATUS    BSS       1              OPERATION STATUS WORD                LEP46280
DTLERR    BSS       0              DETAILED ERROR CODE (NOS)            LEP46290
TAPERR    BSS       1              DETAILED TAPE ERROR (SCOPE)          LEP46300
RSKCNT    BSS       1              RESIDUAL SKIP COUNT (SCOPE)          LEP46310
NWRDXF    BSS       1              NUMBER OF WORDS XFERRED ON READ/WRITELEP46320
ASTCNT    BSS       7                                                   LEP46330
ASTSEC    BSS       8                                                   LEP46340
          IFEQ      OS,SCOPE                                            LEP46350
ASTSYS    BSSZ      1              SYSTEM IDENTIFIER             (SCOPE)LEP46360
          ELSE                                                          LEP46370
ASTSYS    DATA      1              SYSTEM IDENTIFIER               (NOS)LEP46380
          ENDIF                                                         LEP46390
ASTMSG    BSS       9              MESSAGE TEXT AREA                    LEP46400
DEVTYP    BSS       1                                                   LEP46410
PRUSIZ    BSS       1                                                   LEP46420
LFNADS    BSS       1                                                   LEP46430
PRUXEI    BSS       1                                                   LEP46440
NWXF      BSS       1                                                   LEP46450
NWXWRT    BSS       1                                                   LEP46460
OUTMIN    BSS       1              (OUT-IN) ON EXIT FROM FETRET$        LEP46470
          BSS       6              SCRATCH                              LEP46480
FET       BSS       9              FET PROPER                           LEP46490
FETEXT    BSS       3              FET EXTENSION (SCOPE)                LEP46500
ASTQFR    BSS       MAXLDI         QUALIFIERS (USER IDS, OWNERS IDS)    LEP46510
ASTPFN    BSS       MAXLDI         PERMANENT FILENAMES                  LEP46520
ASTLFN    BSS       MAXLDI         LOGICAL FILENAMES                    LEP46530
ASTEQC    BSS       MAXLDI         EQUIPMENT CODES                      LEP46540
ASTOPT    BSS       MAXLDI         ACCESSIBILITY/PERMANENCY OPTIONS     LEP46550
ASTYPE    BSS       MAXLDI         GEN EQUIPMENT TYPE INDICES           LEP46560
ASTUNT    BSS       MAXLDI         UNIT NUMBERS (LEFT FOR COMPATIB)     LEP46570
ASTLOC    BSS       MAXLDI         CURRENT DEVICE LOCATIONS             LEP46580
ASTNXT    BSS       MAXLDI         NEXT (EOI) DEVICE LOCATIONS          LEP46590
ASTLIM    BSS       MAXLDI         DEVICE CAPACITIES                    LEP46600
ASTWXR    BSS       MAXLDI         COUNTS OF WORDS READ                 LEP46610
ASTWXW    BSS       MAXLDI         COUNTS OF WORDS WRITTEN              LEP46620
*COMDECK    DALCOM                                                      LEP46630
C                                                                       LEP46640
      COMMON /CDMDAL/                                                   LEP46650
     $    LDILIB(26),                                                   LEP46660
     $    LIBLDI(4),LIBHDR(4),LIBLIN(4),LIBNSG(4),                      LEP46670
     $    LIBLOC(4),LIBNXT(4),LIBOPR(4),LIBSEG(4),                      LEP46680
     $    LIBSEQ(4),LIBWRT(4),LININP(16),         LINTOC(16),           LEP46690
     $    MAXDAL,   MCTSEG,   MWHSEG,   MWTSEG,   NAMKEY(4),            LEP46700
     $    NCTSEG,   NRTSEG,   NTLINE,   NWLHDR,   NWTSEG                LEP46710
C                                                                       LEP46720
      COMMON /SYMBIO/                                                   LEP46730
     A    CRDFIL,   ERRFIL,   MCHLIN,   MTWLIN,                         LEP46740
     B    PLTFIL,   PPLFIL,   PRTFIL,   PUNFIL,   SYSCRD,               LEP46750
     C    SYSPRT,   TTYINP,   TTYPRT,   TXTFMT,   ZIOSCR                LEP46760
      INTEGER       CRDFIL,   ERRFIL,   MCHLIN,   MTWLIN                LEP46770
      INTEGER       PLTFIL,   PPLFIL,   PRTFIL,   PUNFIL,   SYSCRD      LEP46780
      INTEGER       SYSPRT,   TXTFMT(5),ZIOSCR(96)                      LEP46790
      LOGICAL       TTYINP,   TTYPRT                                    LEP46800
C                                                                       LEP46810
      COMMON //     IPOOL(1)                                            LEP46820
      REAL          POOL(1)                                             LEP46830
      DOUBLE PRECISION        DPOOL(1)                                  LEP46840
      EQUIVALENCE   (IPOOL,POOL,DPOOL)                                  LEP46850
*COMDECK    DALTIT                                                      LEP46860
C***********************************************************************LEP46870
C*    N O S T R A    D A T A    M A N A G E M E N T    S Y S T E M     *LEP46880
C*                                                                     *LEP46890
C*    E Z - D A L    BASIC-LEVEL MANAGER OF DIRECT ACCESS LIBRARIES    *LEP46900
C***********************************************************************LEP46910
*COMDECK    DMECOM                                                      LEP46920
      COMMON /CDMERR/                                                   LEP46930
     A    DMERCD,   DMERCM,   DMERLC,   DMERPM,   IOMERH,   IEHSAV      LEP46940
      INTEGER       DMERCD,   DMERCM,   DMERLC,   DMERPM                LEP46950
      COMMON /CDMETS/                                                   LEP46960
     A    TRARGS,   TROPID,   TRINST,   TRARGL,                         LEP46970
     B    TRSTSZ,   TRTOPM,   TRTOPS,   TRSTAK                          LEP46980
      INTEGER       TRARGS,   TROPID,   TRINST,   TRARGL(10)            LEP46990
      INTEGER       TRSTSZ,   TRTOPM,   TRTOPS,   TRSTAK(48)            LEP47000
*COMDECK    IOMACTL                                                     LEP47010
************************************                                    LEP47020
*  ASSEMBLY CONTROL SPECIFICATIONS *                                    LEP47030
************************************                                    LEP47040
SCOPE     EQU       0              *                                    LEP47050
NOS       EQU       1              *                                    LEP47060
OS        SET       NOS            *                                    LEP47070
          SYSCOM    B1             *                                    LEP47080
*         LIST      S              *                                    LEP47090
*COMDECK    IOMCOM                                                      LEP47100
C                                                                       LEP47110
      COMMON  /CDMAST/        ASTDIM,                                   LEP47120
     A    ASTOSD,   ASTCNT,   ASTSEC,   ASTSYS,   ASTMSG,   ASTPKT,     LEP47130
     B    ASTQFR,   ASTPFN,   ASTLFN,   ASTEQC,   ASTOPT,   ASTYPE,     LEP47140
     C    ASTUNT,   ASTLOC,   ASTNXT,   ASTLIM,   ASTWXR,   ASTWXW      LEP47150
      INTEGER       ASTDIM,   ASTOSD(14), ASTCNT(7), ASTSEC(8)          LEP47160
      INTEGER       ASTSYS,   ASTMSG(9),ASTPKT(25)                      LEP47170
      INTEGER       ASTQFR(16), ASTPFN(16), ASTLFN(16), ASTEQC(16)      LEP47180
      INTEGER       ASTUNT(16), ASTOPT(16), ASTYPE(16)                  LEP47190
      INTEGER       ASTLOC(16), ASTNXT(16), ASTLIM(16)                  LEP47200
      INTEGER       ASTWXR(16), ASTWXW(16)                              LEP47210
      EQUIVALENCE   (IDOPER,ASTOSD(1)), (IOERCD,ASTOSD(2))              LEP47220
*COMDECK    RPMDIB                                                      LEP47230
C                                                                       LEP47240
      COMMON /CDMDAT/                                                   LEP47250
     A    ASPBEG,   ASPEND,   ASPLDI,   BOOTNG,                         LEP47260
     B    IDXCAT,   IDXLAT,   IDXGAT,   IDXRAT,                         LEP47270
     C    KEYCAT,   KEYLAT,   KEYGAT,   KEYRAT,                         LEP47280
     D    GIDBUF,   GIDDMS,   GIDTEM,                                   LEP47290
     E    MSKGID,   MSKLOC,   MSKRID,                                   LEP47300
     F    RPDIND,   RPDFIX,   RPDNAM,   RPDNUM,                         LEP47310
     G    TIMBEG,   TIMDMS,   TIMING,   TYPTAB,                         LEP47320
     H    UPCALL,   UPGREF                                              LEP47330
      INTEGER       ASPBEG,   ASPEND,   ASPLDI                          LEP47340
      INTEGER       GIDBUF,   GIDDMS,   GIDTEM                          LEP47350
      INTEGER       GIDRES(3),IDXTAB(4),KEYTAB(4),RIDRES(4)             LEP47360
      INTEGER       RPDIND,   RPDFIX,   RPDNAM,   RPDNUM                LEP47370
      INTEGER       RPDTAB(4),TYPTAB(4),UPCALL                          LEP47380
      LOGICAL       BOOTNG,   TIMING,   UPGREF                          LEP47390
      EQUIVALENCE   (IDXTAB(1),IDXCAT), (RPDTAB(1),RPDIND)              LEP47400
      EQUIVALENCE   (GIDRES(1),GIDBUF), (RIDRES(1),KEYTAB(1),KEYCAT)    LEP47410
*COMDECK    RPMDAT                                                      LEP47420
      DATA          ASPBEG, ASPEND, ASPLDI /18,32,0/                    LEP47430
      DATA          BOOTNG /.TRUE./                                     LEP47440
      DATA          IDXCAT,IDXLAT,IDXGAT,IDXRAT /1,2,3,4/               LEP47450
      DATA          KEYCAT,KEYLAT,KEYGAT,KEYRAT/3HCAT,3HLAT,3HGAT,3HRAT/LEP47460
      DATA          GIDBUF,GIDDMS,GIDTEM  /4H$BUF,4H$DMS,4H$TEM/        LEP47470
      DATA          MSKGID, MSKRID /2*77777777000000000000B/            LEP47480
      DATA          MSKLOC  /77777777B/                                 LEP47490
      DATA          RPDTAB / 2, 1, 3, 3/                                LEP47500
      DATA          TYPTAB /3RIND, 3RFIX, 3RNAM, 3RNUM/                 LEP47510
      DATA          TIMBEG,TIMDMS,TIMING,UPCALL/0.,0.,.FALSE.,0/        LEP47520
      DATA          UPGREF /.FALSE./                                    LEP47530
*COMDECK    RPMTIT                                                      LEP47540
C***********************************************************************LEP47550
C*    N O S T R A    D A T A    M A N A G E M E N T    S Y S T E M     *LEP47560
C*                                                                     *LEP47570
C*    R P M          R E S O U R C E   P O O L   M A N A G E R         *LEP47580
C***********************************************************************LEP47590
*COMDECK    SYMBIO                                                      LEP47600
      COMMON /SYMBIO/                                                   LEP47610
     A    CRDFIL,   ERRFIL,   MCHLIN,   MTWLIN,                         LEP47620
     B    PLTFIL,   PPLFIL,   PRTFIL,   PUNFIL,   SYSCRD,               LEP47630
     C    SYSPRT,   TTYINP,   TTYPRT,   TXTFMT,   ZIOSCR                LEP47640
      INTEGER       CRDFIL,   ERRFIL,   MCHLIN,   MTWLIN                LEP47650
      INTEGER       PLTFIL,   PPLFIL,   PRTFIL,   PUNFIL,   SYSCRD      LEP47660
      INTEGER       SYSPRT,   TXTFMT(5),ZIOSCR(96)                      LEP47670
      LOGICAL       TTYINP,   TTYPRT                                    LEP47680
*DECK       DMGASP                                                      LEP47690
C=DECK      DMGASP      DMGASP      MIXED                               LEP47700
      SUBROUTINE    DM GASP                                             LEP47710
     $      (ARG1, ARG2, ARG3)                                          LEP47720
C                                                                       LEP47730
C=PURPOSE   ACCESS METHOD OF NOSTRA-DMS                                 LEP47740
C=AUTHOR    C. A. FELIPPA                                               LEP47750
C=VERSION   NOVEMBER 1977                                               LEP47760
C=EQUIPMENT CDC                                                         LEP47770
C=KEYWORDS  AUXILIARY   STORAGE     MANAGER     I/O                     LEP47780
C=KEYWORDS  DATA        MANAGEMENT SYSTEM                               LEP47790
C=EASY-SUB  DMABRT      LFNBF       LFNZF       IOMAPF      IOMCLS      LEP47800
C=EASY-SUB  IOMCPF      IOMDPF      IOMEOF      IOMEPF      IOMEVT      LEP47810
C=EASY-SUB  IOMFET      IOMOPN      IOMPOD      IOMPOT      IOMPRU      LEP47820
C=EASY-SUB  IOMPPF      IOMQFC      IOMRPF      IOMRDR      IOMWTR      LEP47830
C=EASY-SUB  IOMTAB      IOMXEI                                          LEP47840
C=TEST      TESTCIO     TESTPFM                                         LEP47850
C=USAGE     REFER TO DMGASP REFERENCE MANUAL, LMSC-D626839              LEP47860
C                                                                       LEP47870
C                   C O M M O N                                         LEP47880
C                                                                       LEP47890
C=PROCEDURE IOMCOM      CDMETS      CDMERR                              LEP47900
*CALL               IOMCOM                                              LEP47910
*CALL               DMECOM                                              LEP47920
C                                                                       LEP47930
C                   T Y P E   A N D    D I M E N S I O N                LEP47940
C                                                                       LEP47950
      INTEGER       ARG1,     ARG2(2),  ARG3(4)                         LEP47960
      INTEGER       CDLOC,    DEVICX,   DEVTYP,   EDN(2),   EOFCOD      LEP47970
      INTEGER       QFC(3),   REEL,     RETCOD,   RING,     RSKCNT      LEP47980
      INTEGER       EQCODE,             OPTX,     OPTXA                 LEP47990
      INTEGER       PFN,      PFNID,    PFNCY,    PFNRP,    PFNXR       LEP48000
      INTEGER       SECTOR,   SIZREC,   STATUS,   TAPERR,   TYPEX       LEP48010
      INTEGER       TYPIDX,             VRN                             LEP48020
C                                                                       LEP48030
C                   E Q U I V A L E N C E                               LEP48040
C                                                                       LEP48050
      EQUIVALENCE   (IDOPER,ASTOSD(1)),  (IOERCD,ASTOSD(2))             LEP48060
      EQUIVALENCE   (DEVICX,ASTOSD(3)),  (TYPEX, ASTOSD(4))             LEP48070
      EQUIVALENCE   (LCARG1,ASTOSD(5)),  (LCARG2,ASTOSD(6))             LEP48080
      EQUIVALENCE   (LOCDEV,ASTOSD(7)),  (SIZREC,ASTOSD(8))             LEP48090
      EQUIVALENCE   (RETCOD,ASTOSD(9)),  (EOFCOD,ASTOSD(10))            LEP48100
      EQUIVALENCE   (STATUS,ASTOSD(11)), (TAPERR,ASTOSD(12))            LEP48110
      EQUIVALENCE   (RSKCNT,ASTOSD(13)), (NWRDXF,ASTOSD(14))            LEP48120
      EQUIVALENCE   (DEVTYP,ASTPKT(1)),  (SECTOR,ASTPKT(2))             LEP48130
      EQUIVALENCE   (QFC,PFNID), (QFC(2),PFN),  (QFC(3),PFNCY)          LEP48140
C                                                                       LEP48150
C                   D A T A    I N I T I A L I Z A T I O N              LEP48160
C                                                                       LEP48170
      DATA          ASTDIM  /16/                                        LEP48180
      DATA          (ASTCNT(J),J=1,7)  /7*0/                            LEP48190
      DATA          (ASTEQC(J),J=1,16) /16*0/                           LEP48200
      DATA          (ASTLFN(J),J=1,16)                                  LEP48210
     A       /5LTAPE1, 5LTAPE2, 5LTAPE3, 5LTAPE4, 5LTAPE7, 5LTAPE8,     LEP48220
     B        5LTAPE9, 6LTAPE10,6LTAPE11,6LTAPE12,6LTAPE13,6LTAPE14,    LEP48230
     C        6LTAPE15,6LTAPE16,6LTAPE17,6LTAPE18/                      LEP48240
      DATA          (ASTOSD(J),J=1,14) /1H ,13*0/                       LEP48250
      DATA          (ASTPFN(J),J=1,16) /16*0/                           LEP48260
      DATA          (ASTSEC(J),J=1,8)  /4*0,64,64,1,1/                  LEP48270
      DATA          (ASTUNT(J),J=1,16)                                  LEP48280
     A    /1, 2, 3, 4,       7, 8, 9,10,11,12,13,14,15,16,17,18/        LEP48290
      DATA          (ASTYPE(J),J=1,16) /16*4/                           LEP48300
      DATA          (ASTWXR(J),J=1,16) /16*0/                           LEP48310
      DATA          (ASTWXW(J),J=1,16) /16*0/                           LEP48320
      DATA          PFNRP /30/                                          LEP48330
      DATA          DMERCD, DMERCM, DMERLC, DMERPM, IOMERH /5*0/        LEP48340
C                                                                       LEP48350
C                                                                       LEP48360
C              INITIALIZATION/CHECKOUT CODE BLOCK                       LEP48370
C              COMMON TO ALL ENTRY POINTS                               LEP48380
C                                                                       LEP48390
  100 CONTINUE                                                          LEP48400
      ASSIGN 250 TO  LJ DEVX                                            LEP48410
  150 CONTINUE                                                          LEP48420
      DO 160  I = 2,14                                                  LEP48430
        ASTOSD(I) = 0                                                   LEP48440
  160   CONTINUE                                                        LEP48450
      DEVICX =   ARG1                                                   LEP48460
      LDI =      DEVICX                                                 LEP48470
      IF (LDI)                         6100,6100, 180                   LEP48480
  180 IF (LDI - ASTDIM)                 200, 200,6100                   LEP48490
  200 CONTINUE                                                          LEP48500
      TYPEX =    ASTYPE(LDI) - 4                                        LEP48510
      TYPIDX =   TYPEX                                                  LEP48520
      SECTOR =   ASTSEC(TYPEX+5)                                        LEP48530
      EQCODE =   ASTEQC(LDI)                                            LEP48540
      LFN =      ASTLFN(LDI)                                            LEP48550
      PFN =      ASTPFN(LDI)                                            LEP48560
      PFNID =    ASTQFR(LDI)                                            LEP48570
      OPTX =     ASTOPT(LDI)                                            LEP48580
      OPTXA =    IABS(OPTX)                                             LEP48590
      GO TO    LJ DEVX,  (250, 1000, 1800)                              LEP48600
  250 CONTINUE                                                          LEP48610
      NEXT =     ASTNXT(LDI)                                            LEP48620
      LIMIT =    ASTLIM(LDI)                                            LEP48630
      CDLOC =    ASTLOC(LDI)                                            LEP48640
      LOCDEV =   CDLOC                                                  LEP48650
      LOCREC =   LOCDEV + 1                                             LEP48660
      NEWLOC =   LOCREC                                                 LEP48670
C                                                                       LEP48680
C              VERIFY DEVICE IS ACTIVE                                  LEP48690
C                                                                       LEP48700
      IF (EQCODE .EQ. 0)               GO TO 6200                       LEP48710
      GO TO    LJ TASK,  (800, 1200, 2500, 3000, 3500, 4000)            LEP48720
  800 CONTINUE                                                          LEP48730
C                                                                       LEP48740
C=ENTRY     DMDAST      DMDAST    ENTRY                                 LEP48750
C=USAGE     SEE SECTION 3.1 OF DMGASP REF. MNANUAL, LMSC-D626839        LEP48760
C=PURPOSE   DECLARE (ASSIGN, OPEN) AN AUXILIARY STORAGE DEVICE          LEP48770
C=USAGE     SEE SECTION 3.1 OF DMGASP REF. MANUAL, LMSC-D626839         LEP48780
C                                                                       LEP48790
C     ++++++++++++++++++++++                                            LEP48800
      ENTRY         DM D AST                                            LEP48810
C     ++++++++++++++++++++++                                            LEP48820
C                                                                       LEP48830
      IDOPER =   6HDMDAST                                               LEP48840
      ASSIGN 1000 TO  LJ DEVX                                           LEP48850
      GO TO 150                                                         LEP48860
 1000 CONTINUE                                                          LEP48870
C                                                                       LEP48880
C              IF DEVICE IS CURRENTLY ACTIVE, CLOSE IT, THEN OPEN       LEP48890
C                                                                       LEP48900
      IF (EQCODE .EQ. 0)               GO TO 1100                       LEP48910
      ASSIGN  1100 TO  LJ FAST                                          LEP48920
      GO TO 1900                                                        LEP48930
 1100 CONTINUE                                                          LEP48940
      EDN(1) =   ARG2(1)                                                LEP48950
      EDN(2) =   ARG2(2)                                                LEP48960
      TYPEX =    ARG3(1)                                                LEP48970
      OPTX =     ARG3(2)                                                LEP48980
      OPTXA =    IABS(OPTX)                                             LEP48990
      LIMIT =    ARG3(3)                                                LEP49000
      IF (LIMIT .LE. 0)                LIMIT =  262144                  LEP49010
      REEL =     ARG3(4)                                                LEP49020
      IF (REEL .EQ. 1H )               REEL = 0                         LEP49030
      SECTOR =   ASTSEC(TYPEX+5)                                        LEP49040
      NEXT =     0                                                      LEP49050
C                                                                       LEP49060
C              IF EDNAME IS NZ, PROCESS SUPPLIED IDENTIFIER             LEP49070
C                                                                       LEP49080
      CALL       IOM QFC  (EDN,  QFC)                                   LEP49090
C                                                                       LEP49100
C              BRANCH ACCORDING TO EQUIPMENT REQUEST INDEX              LEP49110
C                                                                       LEP49120
      NTRKS =    7                                                      LEP49130
      IF (TYPEX+1)                     1200,1250,1400                   LEP49140
C                                                                       LEP49150
C              --------------------                                     LEP49160
C              MAGNETIC TAPE DEVICE                                     LEP49170
C              --------------------                                     LEP49180
C                                                                       LEP49190
 1200 CONTINUE                                                          LEP49200
      NTRKS =    9                                                      LEP49210
 1250 CONTINUE                                                          LEP49220
      RING =     0                                                      LEP49230
      IF (IABS(OPTX)-1)                1280,1300,1320                   LEP49240
 1280 CONTINUE                                                          LEP49250
      REEL =     1                                                      LEP49260
 1300 CONTINUE                                                          LEP49270
      RING =     1                                                      LEP49280
 1320 CONTINUE                                                          LEP49290
C     CALL       IOM RMT  (LFN, VRN, RING, 0, NTRKS, 0)                 LEP49300
      GO TO 1600                                                        LEP49310
C                                                                       LEP49320
C              --------------------                                     LEP49330
C              DIRECT ACCESS DEVICE                                     LEP49340
C              --------------------                                     LEP49350
C                                                                       LEP49360
 1400 CONTINUE                                                          LEP49370
      LFN =      ASTLFN(LDI)                                            LEP49380
      IF (PFN .EQ. 0)                  GO TO 1420                       LEP49390
      IF (REEL .NE. 0)                 LFN = LFNZF(REEL)                LEP49400
 1420 CONTINUE                                                          LEP49410
C                                                                       LEP49420
      IF (TYPEX - 2)                   1440,7100,7100                   LEP49430
 1440 CONTINUE                                                          LEP49440
C                                                                       LEP49450
C              SECTOR-ADDRESSABLE MASS STORAGE                          LEP49460
C                                                                       LEP49470
      IF (OPTXA .LE. 2)                GO TO 1500                       LEP49480
      PFN =      AND(PFN,-777777B) .OR. PFNCY .OR. 64*PFNRP             LEP49490
      ASTPFN(LDI) = PFN                                                 LEP49500
C                                                                       LEP49510
C              ATTACH PERM FILE TO RUN IF OPTX = 3,4                    LEP49520
C                                                                       LEP49530
      MODE =     OPTXA - 4                                              LEP49540
      IF (MODE .GT. 0)                 GO TO 1450                       LEP49550
      IF (ASTSYS .NE. 0)               MODE = IABS(MODE)                LEP49560
      CALL       IOM APF  (LFN, PFN, PFNID, MODE)                       LEP49570
      IF (STATUS. NE. 0)               GO TO 7100                       LEP49580
      NEXT =     IOM PRU  (LFN)                                         LEP49590
      GO TO 1500                                                        LEP49600
C                                                                       LEP49610
C              IF NEW PERM FILE REQUESTED (OPTX GT 5), ISSUE A          LEP49620
C              EQUIPMENT REQUEST ON SCOPE, OR A DEFINE REQUEST ON NOS   LEP49630
C                                                                       LEP49640
 1450 CONTINUE                                                          LEP49650
      IF (ASTSYS .EQ. 0)               CALL  IOM RPF  (LFN)             LEP49660
      MCT =      MOD(OPTXA+1,2)*2                                       LEP49670
      IF (ASTSYS .NE. 0)               CALL  IOM DPF (LFN, PFN, MCT, 0) LEP49680
      IF (STATUS .NE. 0)               GO TO 7100                       LEP49690
C                                                                       LEP49700
C              OPEN FILE                                                LEP49710
C                                                                       LEP49720
 1500 CONTINUE                                                          LEP49730
      CALL       IOM OPN  (LFN)                                         LEP49740
      DEVTYP=1
C                                                                       LEP49750
 1550 CONTINUE                                                          LEP49760
 1600 CONTINUE                                                          LEP49770
C                                                                       LEP49780
C              INSERT DEVICE DESCRIPTORS IN AUX STORAGE TABLE           LEP49790
C                                                                       LEP49800
      ASTPFN(LDI) = LFN                                                 LEP49810
      ASTQFR(LDI) = PFNID                                               LEP49820
      ASTPFN(LDI) = PFN                                                 LEP49830
      ASTLFN(LDI) = LFN                                                 LEP49840
      ASTEQC(LDI) = DEVTYP                                              LEP49850
      ASTYPE(LDI) = TYPEX + 4                                           LEP49860
      ASTOPT(LDI) = OPTXA                                               LEP49870
      ASTLIM(LDI) = LIMIT                                               LEP49880
      ASTLOC(LDI) = 0                                                   LEP49890
      ASTNXT(LDI) = NEXT                                                LEP49900
      ASTWXR(LDI) = 0                                                   LEP49910
      ASTWXW(LDI) = 0                                                   LEP49920
      GO TO 5000                                                        LEP49930
C                                                                       LEP49940
C=ENTRY     DMFAST      DMFAST    ENTRY                                 LEP49950
C=PURPOSE   FREE (CLOSE, DEACTIVATE) AN AUXILIARY STORAGE DEVICE        LEP49960
C=USAGE     SEE SECTION 3.2 OF DMGASP REF. MANUAL, LMSC-D626839         LEP49970
C                                                                       LEP49980
C     ++++++++++++++++++++++                                            LEP49990
      ENTRY        DM F AST                                             LEP50000
C     ++++++++++++++++++++++                                            LEP50010
C                                                                       LEP50020
      IDOPER =   6HDMFAST                                               LEP50030
      ASSIGN 5000 TO  LJ FAST                                           LEP50040
      ASSIGN 1800 TO  LJ DEVX                                           LEP50050
      GO TO 150                                                         LEP50060
 1800 CONTINUE                                                          LEP50070
C                                                                       LEP50080
      IF (ARG2(1))                     1850,1900,1950                   LEP50090
C                                                                       LEP50100
C              EVICT CONTENTS OF FILE (ERASE)                           LEP50110
C                                                                       LEP50120
 1850 CONTINUE                                                          LEP50130
      CALL       IOM EVT  (LFN)                                         LEP50140
      ASTNXT(LDI) =  0                                                  LEP50150
      GO TO 5000                                                        LEP50160
C                                                                       LEP50170
C              RELEASE FILE FROM JOB (FREE DEVICE).  IF OPTX GE 5,      LEP50180
C              CATALOG NEW PERM FILE IF ON SCOPE.                       LEP50190
C                                                                       LEP50200
 1900 CONTINUE                                                          LEP50210
      IF (ASTSYS .NE. 0)               GO TO 1930                       LEP50220
      IF (OPTXA .LE. 2)                GO TO 1930                       LEP50230
      IF (OPTXA .GE. 5)                GO TO 1920                       LEP50240
      IF (ASTWXW(LDI) .NE. 0)                                           LEP50250
     $CALL       IOM EPF  (LFN, PFN, 0, 0)                              LEP50260
      GO TO 1930                                                        LEP50270
 1920 CONTINUE                                                          LEP50280
      PFNXR =    0                                                      LEP50290
      CALL       IOM CPF  (LFN, PFN, PFNID, PFNXR)                      LEP50300
      IF (STATUS .NE. 0)               GO TO 7100                       LEP50310
 1930 CONTINUE                                                          LEP50320
C                                                                       LEP50330
C              CLOSE FILE                                               LEP50340
C                                                                       LEP50350
      CALL       IOM CLS  (LFN)                                         LEP50360
      ASTEQC(LDI) = 0                                                   LEP50370
      ASTPFN(LDI) = 0                                                   LEP50380
      GO TO    LJ FAST, (1100, 5000)                                    LEP50390
C                                                                       LEP50400
C              PURGE PERMANENT FILE (DECATALOGUE)                       LEP50410
C                                                                       LEP50420
 1950 CONTINUE                                                          LEP50430
      CALL       IOM PPF  (LFN, PFN, 0, 0)                              LEP50440
      ASTEQC(LDI) = 0                                                   LEP50450
      ASTPFN(LDI) = 0                                                   LEP50460
      GO TO 5000                                                        LEP50470
C                                                                       LEP50480
C=ENTRY     DMPAST      DMPAST    ENTRY                                 LEP50490
C=PURPOSE   POSITION AUXILIARY STORAGE DEVICE                           LEP50500
C=USAGE     SEE SECTION 3.3 OF DMGASP REF. MANUAL, LMSC-D626839         LEP50510
C                                                                       LEP50520
C     ++++++++++++++++++++++                                            LEP50530
      ENTRY         DM P AST                                            LEP50540
C     ++++++++++++++++++++++                                            LEP50550
C                                                                       LEP50560
      IDOPER =   6HDMPAST                                               LEP50570
      ASSIGN 2500 TO  LJ TASK                                           LEP50580
      GO TO 100                                                         LEP50590
 2500 CONTINUE                                                          LEP50600
      LCARG1 =   ARG2(1)                                                LEP50610
      LCARG2 =   ARG3(1)                                                LEP50620
      IF  (TYPEX .GE. 0)               GO TO 2800                       LEP50630
C                                                                       LEP50640
C              POSITION MAGNETIC TAPE                                   LEP50650
C                                                                       LEP50660
C     CALL       IOM POT  (LFN, LOCDEV, LCARG1, LCARG2)                 LEP50670
      ASTLOC(LDI) = LOCDEV                                              LEP50680
      IF (STATUS)                      6400,5000,6400                   LEP50690
C                                                                       LEP50700
C               POSITION DIRECT ACCESS DEVICE                           LEP50710
C                                                                       LEP50720
 2800 CONTINUE                                                          LEP50730
      CALL       IOM POD   (LOCDEV, LCARG1, LCARG2, SECTOR)             LEP50740
      IF (LOCDEV)                      6500,2900,2900                   LEP50750
 2900 IF (LOCDEV - LIMIT)              2950,2950,6500                   LEP50760
 2950 ASTLOC(LDI) = LOCDEV                                              LEP50770
      GO TO 5000                                                        LEP50780
C                                                                       LEP50790
C=ENTRY     DMRAST      DMRAST    ENTRY                                 LEP50800
C=PURPOSE   READ RECORD FROM AUXILIARY STORAGE DEVICE                   LEP50810
C=USAGE     SEE SECTION 3.4 OF DMGASP REF. MANUAL, LMSC-D626839         LEP50820
C                                                                       LEP50830
C     ++++++++++++++++++++++                                            LEP50840
      ENTRY         DM R AST                                            LEP50850
C     ++++++++++++++++++++++                                            LEP50860
C                                                                       LEP50870
      IDOPER =   6HDMRAST                                               LEP50880
      ASSIGN 3000 TO  LJ TASK                                           LEP50890
      GO TO 100                                                         LEP50900
 3000 CONTINUE                                                          LEP50910
      SIZREC  =  ARG3(1)                                                LEP50920
      IF (SIZREC)                      6600,6600,3100                   LEP50930
 3100 CONTINUE                                                          LEP50940
      IF (SECTOR .EQ. 0)               GO TO 3200                       LEP50950
      NEWLOC =   NEWLOC + (SIZREC-1)/SECTOR                             LEP50960
      IF (NEWLOC - NEXT)               3200,3200,6700                   LEP50970
 3200 CONTINUE                                                          LEP50980
C                                                                       LEP50990
C              READ DEVICE AND CHECK STATUS WORD                        LEP51000
C                                                                       LEP51010
      CALL       IOM RDR  (LFN, ARG2, SIZREC, LOCREC, TYPEX)            LEP51020
      IF (STATUS .GT. 1)               GO TO 7000                       LEP51030
C                                                                       LEP51040
C              UPDATE DEVICE STATE AND ACCOUNTING PARAMETERS            LEP51050
C                                                                       LEP51060
      ASTCNT(5) =   ASTCNT(5) + 1                                       LEP51070
      ASTWXR(LDI) = ASTWXR(LDI) + SIZREC                                LEP51080
      GO TO 3900                                                        LEP51090
C                                                                       LEP51100
C=ENTRY     DMWAST      DMWAST    ENTRY                                 LEP51110
C=PURPOSE   WRITE RECORD ON AUXILIARY STORAGE DEVICE                    LEP51120
C=USAGE     SEE SECTION 3.5 OF DMGASP REF. MANUAL, LMSC-D626839         LEP51130
C                                                                       LEP51140
C     ++++++++++++++++++++++                                            LEP51150
      ENTRY         DM W AST                                            LEP51160
C     ++++++++++++++++++++++                                            LEP51170
C                                                                       LEP51180
      IDOPER =   6HDMWAST                                               LEP51190
      ASSIGN 3500 TO  LJ TASK                                           LEP51200
      GO TO 100                                                         LEP51210
 3500 CONTINUE                                                          LEP51220
      SIZREC =   ARG3(1)                                                LEP51230
      IF (SIZREC)                      6600,6600,3550                   LEP51240
 3550 CONTINUE                                                          LEP51250
      IF (OPTXA .EQ. 3)                GO TO 6900                       LEP51260
      IF (SECTOR .EQ. 0)               GO TO 3800                       LEP51270
      NEWLOC =   NEWLOC + (SIZREC-1)/SECTOR                             LEP51280
      IF (NEWLOC .GT. LIMIT)           GO TO 6800                       LEP51290
      IF (TYPEX .EQ. 3)                GO TO 3800                       LEP51300
C                                                                       LEP51310
C              IF RECORD IS TO BE WRITTEN BEYOND CURRENT EOI ON         LEP51320
C              MASS STORAGE DEVICE, EXTEND EOI BY DUMMY WRITES          LEP51330
C                                                                       LEP51340
      MORE =     LOCDEV - NEXT                                          LEP51350
      IF (MORE)                      3800,3700,3600                     LEP51360
 3600 CONTINUE                                                          LEP51370
      CALL       IOM XEI  (LFN, MORE)                                   LEP51380
 3700 CONTINUE                                                          LEP51390
      LOCREC =   0                                                      LEP51400
 3800 CONTINUE                                                          LEP51410
      CALL       IOM WTR  (LFN, ARG2, SIZREC, LOCREC, TYPEX)            LEP51420
      IF (STATUS .GT. 1)               GO TO 7000                       LEP51430
C                                                                       LEP51440
C              UPDATE DEVICE STATE AND ACCOUNTING PARAMETERS            LEP51450
C                                                                       LEP51460
      ASTCNT(4) =   ASTCNT(4) + 1                                       LEP51470
      ASTWXW(LDI) = ASTWXW(LDI) + SIZREC                                LEP51480
 3900 CONTINUE                                                          LEP51490
      ASTLOC(LDI) = NEWLOC                                              LEP51500
      ASTNXT(LDI) = MAX0 (NEWLOC,NEXT)                                  LEP51510
      ASTCNT(6) =   ASTCNT(6)   + SIZREC                                LEP51520
      ASTCNT(7) =   ASTCNT(7)   + NWRDXF                                LEP51530
      GO TO 5000                                                        LEP51540
C                                                                       LEP51550
C=ENTRY     DMEAST      DMEAST    ENTRY                                 LEP51560
C=PURPOSE   WRITE EOF ON MAGNETIC TAPE                                  LEP51570
C=USAGE     SEE SECTION 3.6 OF DMGASP REF. MANUAL, LMSC-D626839         LEP51580
C                                                                       LEP51590
C     ++++++++++++++++++++++                                            LEP51600
      ENTRY         DM E AST                                            LEP51610
C     ++++++++++++++++++++++                                            LEP51620
C                                                                       LEP51630
      IDOPER =   6HDMEAST                                               LEP51640
      ASSIGN 4000 TO  LJ TASK                                           LEP51650
      GO TO 100                                                         LEP51660
 4000 CONTINUE                                                          LEP51670
C                                                                       LEP51680
C              WRITE TWO END-OF-FILE MARKS AND BACKSPACE TAPE           LEP51690
C              OVER LAST ONE                                            LEP51700
C                                                                       LEP51710
C     CALL       WRTEOF    (LFN)                                        LEP51720
C     CALL       WRTEOF    (LFN)                                        LEP51730
C     CALL       BSKIPF    (LFN, 1)                                     LEP51740
C                                                                       LEP51750
C              UPDATE DEVICE LOCATION                                   LEP51760
C                                                                       LEP51770
      LOCDEV =   AND (LOCDEV,770000B) + 1000B                           LEP51780
      ASTLOC(LDI) = LOCDEV                                              LEP51790
      ASTNXT(LDI) = LOCDEV                                              LEP51800
      GO TO 5000                                                        LEP51810
C                                                                       LEP51820
C                                                                       LEP51830
C=ENTRY     DMLAST      DMLAST    ENTRY                                 LEP51840
C=PURPOSE   LIST IOM INFORMATION                                        LEP51850
C=USAGE     SEE SECTION 3.7 OF DMGASP REF. MANUAL, LMSC-D626839         LEP51860
C                                                                       LEP51870
C     ++++++++++++++++++++++                                            LEP51880
      ENTRY         DM L AST                                            LEP51890
C     ++++++++++++++++++++++                                            LEP51900
C                                                                       LEP51910
      IF (ARG1 .NE. 0)                 CALL  IOM OSD                    LEP51920
      IF (ARG2(1) .NE. 0)              CALL  IOM FET                    LEP51930
      IF (ARG3(1) .NE. 0)              CALL  IOM TAB                    LEP51940
      GO TO 5000                                                        LEP51950
C                                                                       LEP51960
C=ENTRY     DMNAST      DMNAST    ENTRY                                 LEP51970
C=PURPOSE   CHANGE INTERNAL FILE NAME(S)                                LEP51980
C=USAGE     SEE SECTION 5.2 OF DMGASP REF. MANUAL, LMSC-D626839         LEP51990
C                                                                       LEP52000
C     ++++++++++++++++++++++                                            LEP52010
      ENTRY         DM N AST                                            LEP52020
C     ++++++++++++++++++++++                                            LEP52030
C                                                                       LEP52040
      ASTLFN(LDI) = LFNZF(ARG3(1).AND.MASK(42))                         LEP52050
      NLDI =     ARG2(1) - 1                                            LEP52060
      IF (NLDI .LE. 0)                 GO TO 5000                       LEP52070
      DO 4600  J = 1,NLDI                                               LEP52080
 4600   ASTLFN(LDI+J) =  LFNINC(ASTLFN(LDI+J-1))                        LEP52090
C                                                                       LEP52100
 5000 CONTINUE                                                          LEP52110
      RETURN                                                            LEP52120
C                                                                       LEP52130
C              -----------                                              LEP52140
C              ERROR EXITS                                              LEP52150
C              -----------                                              LEP52160
C                                                                       LEP52170
C              ILLEGAL DEVICE INDEX                                     LEP52180
C                                                                       LEP52190
 6100 IOERCD =   1                                                      LEP52200
      GO TO 8000                                                        LEP52210
C                                                                       LEP52220
C              ATTEMPT TO POSITION, READ OR WRITE INACTIVE DEVICE       LEP52230
C                                                                       LEP52240
 6200 IOERCD =   2                                                      LEP52250
      GO TO 8000                                                        LEP52260
C                                                                       LEP52270
C              RESERVED ERROR CODE                                      LEP52280
C                                                                       LEP52290
C6300 IOERCD =   3                                                      LEP52300
C     GO TO 8000                                                        LEP52310
C                                                                       LEP52320
C              ILLEGAL TAPE POSITIONING                                 LEP52330
C                                                                       LEP52340
 6400 IOERCD =   4                                                      LEP52350
      GO TO 8000                                                        LEP52360
C                                                                       LEP52370
C               ILLEGAL MASS STORAGE / ECS POSITIONING                  LEP52380
C                                                                       LEP52390
 6500 IOERCD =   5                                                      LEP52400
      GO TO 8000                                                        LEP52410
C                                                                       LEP52420
C              ILLEGAL RECORD SIZE                                      LEP52430
C                                                                       LEP52440
 6600 IOERCD =   6                                                      LEP52450
      GO TO 8000                                                        LEP52460
C                                                                       LEP52470
C              ATTEMPT TO READ MASS STORAGE AREA BEYOND EOI             LEP52480
C                                                                       LEP52490
 6700 IOERCD =   7                                                      LEP52500
      GO TO 8000                                                        LEP52510
C                                                                       LEP52520
C              DEVICE OVERFLOW ON WRITE OP                              LEP52530
C                                                                       LEP52540
 6800 IOERCD =   8                                                      LEP52550
      ASTLIM(LDI) = -ASTLIM(LDI)                                        LEP52560
      GO TO 8000                                                        LEP52570
C                                                                       LEP52580
C              ATTEMPT TO WRITE ON PROTECTED FILE                       LEP52590
C                                                                       LEP52600
 6900 IOERCD =   9                                                      LEP52610
      GO TO 8000                                                        LEP52620
C                                                                       LEP52630
C              MISCELLANEOUS ERROR DETECTED BY I/O HANDLER              LEP52640
C                                                                       LEP52650
 7000 IOERCD =   10                                                     LEP52660
      GO TO 8000                                                        LEP52670
C                                                                       LEP52680
C              UNABLE TO HONOR CONTROL CARD REQUEST                     LEP52690
C                                                                       LEP52700
 7100 IOERCD =   11                                                     LEP52710
      GO TO 8000                                                        LEP52720
C                                                                       LEP52730
C              CONTROL CARD FORMAT ERROR                                LEP52740
C                                                                       LEP52750
C7200 CONTINUE                                                          LEP52760
C                                                                       LEP52770
C              POSTMORTEM ERROR PROCEDURE                               LEP52780
C                                                                       LEP52790
 8000 CONTINUE                                                          LEP52800
      IF (IOMERH - 1)                  5000,8500,8500                   LEP52810
 8500 CONTINUE                                                          LEP52820
      CALL       IOM OSD                                                LEP52830
      IF (IOERCD .GE. 10)              CALL  IOM FET                    LEP52840
      IF (IOMERH .GE. 2)               CALL  IOM TAB                    LEP52850
      IF (IOMERH .GE. 3)               CALL  DM ABRT                    LEP52860
      CALL       IOFATE                                                 LEP52870
      GO TO 5000                                                        LEP52880
      END                                                               LEP52890
*DECK       IOMCIO                                                      LEP52900
* =DECK      IOMCIO      IOMCIO      ASSEMBLY                           LEP52910
          IDENT     IOMCIO                                              LEP52920
          TITLE     COMBINED INPUT/OUTPUT FUNCTIONS                     LEP52930
          SPACE     3                                                   LEP52940
*CALL       IOMACTL                                                     LEP52950
          IFEQ      OS,NOS         *                                    LEP52960
************************************                               (NOS)LEP52970
*    EXTERNAL TEXT COMMON DECKS    *                               (NOS)LEP52980
************************************                               (NOS)LEP52990
*         LIST      X              *                               (NOS)LEP53000
          XTEXT     COMCCIO        *  I/O REQUEST PROCESSOR        (NOS)LEP53010
          XTEXT     COMCLFM        *  LOCAL FILE MANAGER REQUESTS  (NOS)LEP53020
          XTEXT     COMCSYS        *  SYSTEM REQUEST ROUTINES      (NOS)LEP53030
          ENDIF                    *                                    LEP53040
************************************                                    LEP53050
COMMON    SPACE     2                                                   LEP53060
***       COMMON BLOCK DECLARATIONS                                     LEP53070
*                                                                       LEP53080
*                                                                       LEP53090
* =PROCEDURE CDMASTA     CDMERRA     CDMETSA                            LEP53100
*CALL        CDMASTA                                                    LEP53110
*CALL        CDMERRA                                                    LEP53120
          USE       /CDMPAD/                                            LEP53130
BUFSIZ    SET       300B                                                LEP53140
BUFPRU    SET       BUFSIZ/100B                                         LEP53150
CMSIZ     BSSZ      1              CURRENT CM FL                        LEP53160
BCSIZ     BSS       1              BLANK COMMON SIZE                    LEP53170
REQCM     BSS       1              REQUESTED CM FL                      LEP53180
LWAREC    BSS       1                                                   LEP53190
PAD       BSS       0                                                   LEP53200
PADDING   BSS       0                                                   LEP53210
BUFFER    BSS       BUFSIZ         UTILITY BUFFER AREA                  LEP53220
          USE       //                                                  LEP53230
BCFWA     BSS       1                                                   LEP53240
*                                                                       LEP53250
          USE       0                                                   LEP53260
          SPACE     3                                                   LEP53270
SYSREQ    TITLE     MISCELLANEOUS SYSTEM ACTION REQUESTS                LEP53280
************************************************************************LEP53290
*                                                                      *LEP53300
*         MISCELLANEOUS REQUESTS ISSUED TO MONITOR                     *LEP53310
*                                                                      *LEP53320
*         AUTHOR -  C. A. FELIPPA, NOV 1975                            *LEP53330
*         UPDATE -  OCTOBER 1977  (SCOPE/NOS)                          *LEP53340
*                                                                      *LEP53350
************************************************************************LEP53360
*                                                                      *LEP53370
*         AN ENTRY POINT SUMMARY FOLLOWS.                              *LEP53380
*                                                                      *LEP53390
*         DMABRT    CAUSES ERROR TERMINATION OF JOB                    *LEP53400
*                                                                      *LEP53410
*         DMCLOK    RETURNS CURRENT READING OF SYSTEM CLOCK IN         *LEP53420
*                   DISPLAY CODE FORMAT HH.MM.SS                       *LEP53430
*                                                                      *LEP53440
*         DMCMFL    TO ADJUST CENTRAL MEMORY FIELD LENGTH (CM FL)      *LEP53450
*                   OR TO REQUEST INFORMATION ON CURRENT CM FL.        *LEP53460
*                                                                      *LEP53470
*         DMCMFL$   COMPASS-CALLABLE, REGISTER-RESTORING VERSION       *LEP53480
*                   OF DMCMFL.                                         *LEP53490
*                                                                      *LEP53500
*         DMDATE    RETURNS CURRENT DATE IN DISPLAY CODE FORMAT        *LEP53510
*                   MM/DD/YY  AND CLOCK READING  HH.MM.SS              *LEP53520
*                                                                      *LEP53530
*         DMRUNT    RETURNS CP TIME USED BY JOB.  ON SCOPE, IT         *LEP53540
*                   ALSO RETURNS IO TIME AND CP TIME LIMIT.            *LEP53550
*                                                                      *LEP53560
************************************************************************LEP53570
DMABRT    SPACE     2                                                   LEP53580
***       DMABRT                                                        LEP53590
*                                                                       LEP53600
*         ENTRY POINT TO FORCE ABNORMAL JOB TERMINATION                 LEP53610
*                                                                       LEP53620
*         FORTRAN REFERENCE&                                            LEP53630
*                                                                       LEP53640
*         CALL      DMABRT                                              LEP53650
*                                                                       LEP53660
          ENTRY     DMABRT                                              LEP53670
DMABRT    BSS       1              ENTRY POINT                          LEP53680
          ABORT                    LASCIATE OGNI SPERANZA               LEP53690
*                                  VOI CHE ENTRATE                      LEP53700
DMCLOK    SPACE     2                                                   LEP53710
***       DMCLOK (TIME)                                                 LEP53720
*                                                                       LEP53730
*         ENTRY POINT TO READ SYSTEM CLOCK                              LEP53740
*                                                                       LEP53750
*         CALL   DMCLOK  (TIME)                                         LEP53760
*                                                                       LEP53770
*         TIME      CURRENT CLOCK READING IN DISPLAY CODE FORMAT        LEP53780
*                   HH.MM.SS  (OR *HH.MM.SS IF ELAPSED TIME SINCE       LEP53790
*                   DEADSTART IS RETURNED)                              LEP53800
*                                                                       LEP53810
          ENTRY     DMCLOK                                              LEP53820
DMCLOK    BSS       1                                                   LEP53830
          BX5       X1             (X5) = ADDRESS(TIME)            (FTN)LEP53840
          SB1       1                                                   LEP53850
          CLOCK     TIMLOC         CLOCK MACRO                          LEP53860
          SA1       TIMLOC                                              LEP53870
          BX6       X1                                                  LEP53880
          SA6       X5             STORE TIME                           LEP53890
          EQ        DMCLOK         RETURN TO CALLING PROGRAM            LEP53900
TIMLOC    EQU       PAD+174B                                            LEP53910
DMCMSZ    SPACE     2                                                   LEP53920
***       DMCMSZ  (REQCM, CMSIZ, BCSIZ)                                 LEP53930
*                                                                       LEP53940
*         ENTRY POINT TO MODIFY CENTRAL MEMORY FIELD LENGTH, OR         LEP53950
*         TO GET INFORMATION ABOUT CM FIELD LENGTH.                     LEP53960
*                                                                       LEP53970
*         FORTRAN REFERENCE -                                           LEP53980
*                                                                       LEP53990
*         CALL      DMCMSZ  (REQCM, CMSIZ, BCSIZ)                       LEP54000
*                                                                       LEP54010
*         WHERE                                                         LEP54020
*                                                                       LEP54030
*         REQCM     DESIRED NEW CM FL IN WORDS IF REQUESTING CORE       LEP54040
*                   EXPANSION OR CONTRACTION.  ZERO TO REQUEST          LEP54050
*                   INFORMATION ABOUT CURRENT CMSIZ/BCSIZ.              LEP54060
*                                                                       LEP54070
*         CMSIZ     CENTRAL MEMORY FL ON EXIT FROM THIS ROUTINE.        LEP54080
*                   IF REQCM GT 0, AND THE REQUEST IS SUCCESSFUL,       LEP54090
*                   CMFL IS REQCM ROUNDED UP TO NEAREST 100B MULTIPLE.  LEP54100
*                                                                       LEP54110
*         BCSIZ     BLANK COMMON SIZE ON COMPLETION OF REQUEST.         LEP54120
*                                                                       LEP54130
          ENTRY     DMCMSZ                                              LEP54140
DMCMSZ    BSS       1              ENTRY/EXIT POINT                     LEP54150
          SB7       1              (B7) = 1                             LEP54160
          SA2       A1+B7          (X2) = ADDRESS(CMSIZ)           (FTN)LEP54170
          SA1       X1             (X1) = REQCM                    (FTN)LEP54180
          MX0       -18D                                           (FTN)LEP54190
          SA3       A2+B7          (X3) = ADDRESS(BCSIZ)           (FTN)LEP54200
          BX6       -X0*X1         LIMIT REQCM TO 2**18-1               LEP54210
          LX7       X3             (X7) = ADDRESS(BCSIZ)                LEP54220
          BX1       X6             KEEP REQCM IN (X1)                   LEP54230
          SA6       REQCM          SAVE REQCM ON COMMON BLOCK           LEP54240
          LX6       30D                                                 LEP54250
          SA6       MEMREQ         SET UP REQUEST WORD                  LEP54260
          SB6       B7+B7          (B6) = 2                             LEP54270
          BX6       X2             (X6) = ADDRESS(CMSIZ)                LEP54280
          SA7       A6+B6          SAVE ADDRESS(BCSIZ)                  LEP54290
          SA6       A6+B7          SAVE ADDRESS(CMSIZ)                  LEP54300
          ZR        X1,DMCMSZ1     SKIP PRINT IF REQCM=0                LEP54310
          SA5       RFLMESS+1                                           LEP54320
          RJ        =XNCOCTL$      ENCODE REQCM INTO (X6)               LEP54330
          SA4       RFLMESS                                             LEP54340
          SA6       ASTMSG+2       SET ASTMSG(3)                        LEP54350
          LX7       X5                                                  LEP54360
          BX6       X4                                                  LEP54370
          SA7       A6-B7          SET ASTMSG(2)                        LEP54380
          SA6       A7-B7          SET ASTMSG(1)                        LEP54390
          RJ        =XIOMESSG      PRINT  REQUESTED CML  MESSAGE        LEP54400
DMCMSZ1   BSS       0                                                   LEP54410
          SB1       1                                                   LEP54420
          MEMORY    CM,MEMREQ,R,,1 MEMORY MACRO                         LEP54430
          SA1       MEMREQ         (X1) = REQUEST/REPLY WORD            LEP54440
          SB4       BCFWA          (B4) = FWA OF BLANK COMMON           LEP54450
          SA2       A1+B1          (X2) = ADDRESS(CMSIZ)                LEP54460
          MX0       -18D                                                LEP54470
          AX1       30D            RIGHTADJUST CURRENT FL               LEP54480
          SA3       A2+B1          (X3) = ADDRESS(BCSIZ)                LEP54490
          SB4       B1-B4                                               LEP54500
          SB6       B1+B1          (B6) = 2                             LEP54510
          BX6       -X0*X1         (X6) = CMSIZ = CURRENT CM FL         LEP54520
          SX7       X6+B4          (X7) = BCSIZ = CMSIZ-BC(0)           LEP54530
          SA4       NFLMESS                                             LEP54540
          SA6       CMSIZ          STORE CMSIZ IN /CDMPAD/              LEP54550
          SA5       A4+B1                                               LEP54560
          SB4       X7             SAVE BCSIZ IN (B4) FOR PRINT         LEP54570
          SA7       A6+B1          STORE BCSIZ IN /CDMPAD/              LEP54580
          SA6       X2             STORE CMSIZ IN 2ND ARG OF DMCMSZ     LEP54590
          SA7       X3             STORE BCSIZ IN 3RD ARG OF DMCMSZ     LEP54600
          BX6       X4                                                  LEP54610
          SA6       ASTMSG+1       PLACE TEXT IN ASTMSG(2)              LEP54620
          LX7       X5                                                  LEP54630
          SA7       A6+B6          PLACE TEXT IN ASTMSG(4)              LEP54640
          RJ        =XNCOCTL$      OCTAL ENCODE CMSIZ IN (X6)           LEP54650
          SA6       A7-B1          PLACE ENCODED CMFL IN ASTMSG(3)      LEP54660
          SX1       B4             (X1) = BCSIZ                         LEP54670
          RJ        =XNCOCTL$      OCTAL ENCODE BCSIZ IN (X6)           LEP54680
          SA6       A7+B1          PLACE ENCODED BCSIZ IN ASTMSG(5)     LEP54690
          RJ        =XIOMESSG      PRINT INFORMATIVE MESSAGE            LEP54700
          EQ        DMCMSZ         RETURN TO CALLING PROGRAM            LEP54710
MEMREQ    EQU       PAD+170B                                            LEP54720
RFLMESS   DIS       2,0+++      REQ CMSIZ&                              LEP54730
NFLMESS   DIS       2,JOB CMSIZ&, BC SIZE&                              LEP54740
DMCMSZ$   SPACE     2                                                   LEP54750
***       DMCMSZ$                                                       LEP54760
*                                                                       LEP54770
*         COMPASS-CALLABLE, REGISTER-RESTORING, GROIN-KICKING           LEP54780
*         VERSION OF DMCMSZ.                                            LEP54790
*                                                                       LEP54800
*         COMPASS REFERENCE -                                           LEP54810
*                                                                       LEP54820
*         (X7) =    REQCM  (SEE DMCMSZ)                                 LEP54830
*         RJ        GETCML$                                             LEP54840
*                                                                       LEP54850
*         REGISTER UTILIZATION -                                        LEP54860
*         ENTRY REGISTER SET ASSUMED - (B1)=(B7)=1, (B6)=2              LEP54870
*         X1,X6,A1,A2,A3,A4,A5,A6,A7    DESTROYED                       LEP54880
*         X0,X2,X3,X4,X5,B2,B3,B4,B5    PRESERVED                       LEP54890
*         (B1),(B6),(B7) RESTORED TO 1,2,1, RESPECTIVELY.               LEP54900
*         (X1) = CMSIZ = CURRENT CM FL ON RETURN FROM DMCMSZ$.          LEP54910
*                                                                       LEP54920
          ENTRY     DMCMSZ$                                             LEP54930
DMCMSZ$   BSSZ      1                                                   LEP54940
          SA7       REQCM          STORE (X7) IN REQCM WORD             LEP54950
          SB7       1                                                   LEP54960
          LX6       X5                                                  LEP54970
          BX7       X4                                                  LEP54980
          SA6       SAVE+1         (X5) TO SAVE+1                       LEP54990
          SB6       B7+B7                                               LEP55000
          SA7       A6+B7          (X4) TO SAVE+2                       LEP55010
          BX6       X3                                                  LEP55020
          LX7       X2                                                  LEP55030
          SA6       A6+B6          (X3) TO SAVE+3                       LEP55040
          BX6       X0                                                  LEP55050
          SA7       A7+B6          (X2) TO SAVE+4                       LEP55060
          SA6       A6+B6          (X0) TO SAVE+5                       LEP55070
          SX6       B5                                                  LEP55080
          SX7       B4                                                  LEP55090
          SA6       A6+B7          (B5) TO SAVE+6                       LEP55100
          SX6       B3                                                  LEP55110
          SA7       A6+B7          (B4) TO SAVE+7                       LEP55120
          SX7       B2                                                  LEP55130
          SA6       A6+B6          (B3) TO SAVE+8                       LEP55140
          SA7       A7+B6          (B2) TO SAVE+9                       LEP55150
          SA1       REQCMADS       (A1) POINTS TO ARG ADS LIST     (FTN)LEP55160
          RJ        DMCMSZ         EXECUTE DMCMSZ                       LEP55170
          SB7       1              RESTORE (B7) = 1                     LEP55180
          SA1       SAVE+9                                              LEP55190
          SB6       B7+B7          RESTORE (B6) = 2                     LEP55200
          SA2       A1-B7                                               LEP55210
          SA3       A1-B6                                               LEP55220
          SA4       A2-B6                                               LEP55230
          SB2       X1             RESTORE (B2)                         LEP55240
          SA1       A4-B7                                               LEP55250
          SB3       X2             RESTORE (B3)                         LEP55260
          SA2       A1-B7          RESTORE (X2)                         LEP55270
          SB4       X3             RESTORE (B4)                         LEP55280
          SA3       A2-B7          RESTORE (X3)                         LEP55290
          SB5       X4             RESTORE (B5)                         LEP55300
          SA4       A3-B7          RESTORE (X4)                         LEP55310
          BX0       X1             RESTORE (X0)                         LEP55320
          SA1       CMSIZ          (X1) = CMSIZ  ON RETURN              LEP55330
          SA5       A4-B7          RESTORE (X5)                         LEP55340
          SB1       B7             RESTORE (B1) = 1                     LEP55350
          EQ        DMCMSZ$        RETURN                               LEP55360
SAVE      EQU       PADDING+100B                                        LEP55370
REQCMADS  VFD       42/0,18/REQCM  ADDRESS(REQCM)                       LEP55380
CMSIZADS  VFD       42/0,18/CMSIZ  ADDRESS(CMSIZ)                       LEP55390
BCSIZADS  VFD       42/0,18/BCSIZ  ADDRESS(BCSIZ)                       LEP55400
DMCONV    SPACE     2                                                   LEP55410
***       DMCONV                                                        LEP55420
*                                                                       LEP55430
          ENTRY     DMCONV                                              LEP55440
DMCONV    BSS       1                                                   LEP55450
          SX6       1                                                   LEP55460
          SA6       DMERCM                                              LEP55470
          EQ        DMCONV                                              LEP55480
*                                                                       LEP55490
DMDATE    SPACE     2                                                   LEP55500
***       DMDATE  (DATIM)                                               LEP55510
*                                                                       LEP55520
*         ENTRY POINT TO RETRIEVE CURRENT DATE AND TIME                 LEP55530
*                                                                       LEP55540
*         CALL   DMDATE  (DATIM)                                        LEP55550
*                                                                       LEP55560
*         DATIM     A TWO-WORD ARRAY. CURRENT DATE WILL BE              LEP55570
*                   RETURNED IN DATIM(1) IN DISPLAY CODE FORMAT         LEP55580
*                   MMDDYY LEFTJUSTIFIED WITH BLANK FILL.               LEP55590
*                   THE CURRENT TIME WILL BE STORED IN DATIM(2),        LEP55600
*                   IN FORMAT HHMMSS ALSO LEFTJUSTIFIED BLANKFILLED.    LEP55610
*                                                                       LEP55620
          ENTRY     DMDATE                                              LEP55630
DMDATE    BSSZ      1              ENTRY/EXIT POINT                     LEP55640
          BX5       X1             (X5) = ADDRESS(DATIM)           (FTN)LEP55650
          SB1       1              (B1) = 1                             LEP55660
          DATE      TIMLOC         DATE MACRO                           LEP55670
          CLOCK     TIMLOC+1       CLOCK MACRO                          LEP55680
          SA1       TIMLOC                                              LEP55690
          SA4       =4R                                                 LEP55700
          MX0       12                                                  LEP55710
          SB2       6                                                   LEP55720
          LX1       6                                                   LEP55730
          LX2       B2,X1                                               LEP55740
          BX1       X0*X1                                               LEP55750
          LX3       B2,X2                                               LEP55760
          LX0       48                                                  LEP55770
          BX2       X0*X2                                               LEP55780
          LX0       48                                                  LEP55790
          BX3       X0*X3                                               LEP55800
          BX6       X1+X2                                               LEP55810
          SA1       A1+B1                                               LEP55820
          BX6       X6+X3                                               LEP55830
          BX6       X6+X4                                               LEP55840
          MX0       12                                                  LEP55850
          SA6       X5             STORE DATIM(1)                       LEP55860
          LX1       6                                                   LEP55870
          LX2       B2,X1                                               LEP55880
          LX3       B2,X2                                               LEP55890
          BX1       X0*X1                                               LEP55900
          LX0       48                                                  LEP55910
          BX2       X0*X2                                               LEP55920
          LX0       48                                                  LEP55930
          BX3       X0*X3                                               LEP55940
          BX7       X1+X2                                               LEP55950
          BX7       X7+X3                                               LEP55960
          BX7       X7+X4                                               LEP55970
          SA7       X5+B1          STORE DATIM(2)                       LEP55980
          EQ        DMDATE         RETURN TO CALLING PROGRAM            LEP55990
DMFATE    SPACE     2                                                   LEP56000
***       DMFATE                                                        LEP56010
*                                                                       LEP56020
          ENTRY     DMFATE                                              LEP56030
DMFATE    BSS       1                                                   LEP56040
          SA2       DMSERRJ                                             LEP56050
          SA1       DMSERRL                                        (FTN)LEP56060
          MX0       -18                                                 LEP56070
          BX2       -X0*X2                                              LEP56080
DMSERRJ   ZR        X2,DMABRT      DIRECT ABORT IF NO USER-SPEC ROUTINE LEP56090
          RJ        0              TRANSFER TO DMTERM-SPECIFIED ENTRY   LEP56100
DMSERRL   VFD       42/0,18/=3HDMS                                      LEP56110
          VFD       42/0,18/DMERCD                                      LEP56120
DMHAST    SPACE     2                                                   LEP56130
***       DMHAST  (IERH, UPGERR, 0)                                     LEP56140
*                                                                       LEP56150
          ENTRY     DMHAST                                              LEP56160
DMHAST    BSS       1                                                   LEP56170
          SA2       A1+1                                           (FTN)LEP56180
          SA1       X1             (X1) = IERH                     (FTN)LEP56190
          MX0       -18                                                 LEP56200
          SA5       IOMERRJ                                             LEP56210
          BX7       X1                                                  LEP56220
          SA3       X2             (X3) = VALUE(UPGERR)                 LEP56230
          BX6       X0*X5          MASK OUT RJ ADDRESS FIELD            LEP56240
          SA7       IOMERH         SET IOM ERROR HANDLING FLAG          LEP56250
          SA6       A5                                                  LEP56260
          ZR        X3,DMHAST      EXIT IF ZERO SECOND ARGUMENT         LEP56270
          BX2       -X0*X2                                              LEP56280
          BX6       X6+X2                                               LEP56290
          SA6       A6             STORE TRANSFER TO UPGERR             LEP56300
          EQ        DMHAST                                              LEP56310
*                                                                       LEP56320
DMRUNT    SPACE     2                                                   LEP56330
***       DMRUNT  (CPTIME, IOTIME, CPTLIM)                              LEP56340
*                                                                       LEP56350
*         ENTRY POINT TO OBTAIN PROGRAM TIMING INFORMATION              LEP56360
*                                                                       LEP56370
*         CALL   DMRUNT  (CPTIME, IOTIME, TIMLIM)                       LEP56380
*                                                                       LEP56390
*         CPTIME    ELAPSED CP TIME IN F.P. SECONDS                     LEP56400
*                                                                       LEP56410
*         IOTIME    ELAPSED I/O TIME IN F.P. SECONDS                    LEP56420
*                                                                       LEP56430
*         TIMLIM    JOB CP TIME LIMIT IN F.P. SECONDS                   LEP56440
*                                                                       LEP56450
          ENTRY     DMRUNT                                              LEP56460
DMRUNT    BSSZ      1                                                   LEP56470
          SB7       1                                                   LEP56480
          SA2       A1+B7                                          (FTN)LEP56490
          SB1       X1                                             (FTN)LEP56500
          SA3       A2+B7                                          (FTN)LEP56510
          SB2       X2                                             (FTN)LEP56520
          SB3       X3                                             (FTN)LEP56530
          MX6       0                                                   LEP56540
          SB1       B7                                                  LEP56550
          SA6       TIMLOC+1                                            LEP56560
          TIME      TIMLOC         GET TIME LIMIT, AND CP TIME          LEP56570
          IFEQ      OS,SCOPE                                            LEP56580
          IOTIME    TIMLOC+1       GET IO TIME                   (SCOPE)LEP56590
          ENDIF                                                         LEP56600
          SA1       TIMLOC         (X1) = 24/CPTLIM,36/CPTIME(SEC,MSEC) LEP56610
          MX0       24D                                                 LEP56620
          SA2       A1+B7          (X2) = 24/IOTLIM,36/IOTIME(SEC,MSEC) LEP56630
          BX6       X0*X1          (X6) = ISOLATED TIMLIM FIELD         LEP56640
          BX1       -X0*X1         CLEAR CPTLIM FIELD                   LEP56650
          LX6       24D                                                 LEP56660
          BX2       -X0*X2         CLEAR IOTLIM FIELD                   LEP56670
          MX0       -12D                                                LEP56680
          PX6       X6                                                  LEP56690
          NX6       X6                                                  LEP56700
          BX3       -X0*X1         (X3) = CPTIME MSEC (INTEGER)         LEP56710
          BX4       -X0*X2         (X4) = IOTIME MSEC (INTEGER)         LEP56720
          SA6       B3             STORE CP TIME LIMTI                  LEP56730
          SX5       1000D                                               LEP56740
          AX1       12D            RIGHTJUSTIFY CPTIME SECS             LEP56750
          AX2       12D            RIGHTJUSTIFY IOTIME SECS             LEP56760
          DX1       X1*X5          (X1) = CPTIME SECS TO MILLISEC       LEP56770
          DX2       X2*X5          (X1) = IOTIME SECS TO MILLISEC       LEP56780
          SA5      =0.001          (X5) = MSEC TO SEC CONV FACTOR       LEP56790
          IX1       X1+X3                                               LEP56800
          IX2       X2+X4                                               LEP56810
          PX1       X1                                                  LEP56820
          PX2       X2                                                  LEP56830
          NX1       X1                                                  LEP56840
          NX2       X2                                                  LEP56850
          RX6       X1*X5                                               LEP56860
          RX7       X2*X5                                               LEP56870
          SA6       B1             STORE ELAPSED CP TIME (F.P. SECS)    LEP56880
          SA7       B2             STORE ELAPSED IO TIME (F.P. SECS)    LEP56890
          EQ        DMRUNT         RETURN TO CALLING PROGRAM            LEP56900
DMTERM    SPACE     2                                                   LEP56910
*                                                                       LEP56920
***       DMTERM  (UPGERR)                                              LEP56930
*                                                                       LEP56940
          ENTRY     DMTERM                                              LEP56950
DMTERM    BSS       1                                                   LEP56960
          SA2       DMSERRJ                                             LEP56970
          MX0       -18                                                 LEP56980
          BX2       X0*X2                                               LEP56990
          BX6       X1+X2                                               LEP57000
          SA6       A2                                                  LEP57010
          EQ        DMTERM                                              LEP57020
DMUSER    SPACE     2                                                   LEP57030
***       DMUSER (NAME)                                                 LEP57040
*                                                                       LEP57050
          ENTRY     DMUSER                                              LEP57060
DMUSER    BSS       1                                                   LEP57070
          SA1       X1                                             (FTN)LEP57080
          BX6       X1                                                  LEP57090
          SA6       TRSTAK                                              LEP57100
          EQ        DMUSER                                              LEP57110
IOFATE    SPACE     2                                                   LEP57120
***       IOFATE                                                        LEP57130
*                                                                       LEP57140
          ENTRY     IOFATE                                              LEP57150
IOFATE    BSS       1                                                   LEP57160
          SA2       IOMERRJ                                             LEP57170
          SA1       IOMERRL                                        (FTN)LEP57180
          MX0       -18                                                 LEP57190
          BX2       -X0*X2                                              LEP57200
IOMERRJ   ZR        X2,IOFATE      RETURN IF NO USER-SPECIFIED ROUTINE  LEP57210
          RJ        0              ELSE JUMP TO IT                      LEP57220
          EQ        IOFATE                                              LEP57230
IOMERRL   VFD       42/0,18/=3HIOM                                      LEP57240
          VFD       42/0,18/DMERCD                                      LEP57250
*                                                                       LEP57260
          TITLE     PROCEDURES FOR PHYSICAL DATA TRANSMISSION           LEP57270
************************************************************************LEP57280
*         PROCEDURES INVOLVING ACTUAL DATA TRANSFER BETWEEN            *LEP57290
*         CENTRAL MEMORY AND AUXILIARY STORAGE                         *LEP57300
*                                                                      *LEP57310
*         AUTHOR -  C. A. FELIPPA, SEPT. 1975                          *LEP57320
*         UPDATE -  NOVEMBER 1977                                      *LEP57330
*                                                                      *LEP57340
************************************************************************LEP57350
*                                                                      *LEP57360
*         ENTRY POINT SUMMARY -                                        *LEP57370
*                                                                      *LEP57380
*         IOMEOF    WRITES AN END-OF-FILE MARK                         *LEP57390
*                                                                      *LEP57400
*         IOMPRU    GET MASS STORAGE FILE SIZE (IN PRUS)               *LEP57410
*                                                                      *LEP57420
*         IOMRDR    TRANSFERS A DATA BLOCK (RECORD) FROM AN AUX        *LEP57430
*                   STORAGE DEVICE CHARACTERIZED BY A DMGASP DEVICE    *LEP57440
*                   TYPE INDEX, TO MAIN STORAGE.  (ALT ENTRY RDMS      *LEP57450
*                   ASSUMES SECTOR-ADDRESSABLE MASS STORAGE).          *LEP57460
*                                                                      *LEP57470
*         IOMWTR    TRANSFERS A DATA BLOCK (RECORD) FROM MAIN          *LEP57480
*                   STORAGE TO AN AUX STORAGE DEVICE CHARACTERIZED     *LEP57490
*                   A DMGASP DEVICE TYPE INDEX.  (ALT ENTRY WTMS       *LEP57500
*                   ASSUMES SECTOR-ADDRESSABLE MASS STORAGE.)          *LEP57510
*                                                                      *LEP57520
*         IOMXEI    EXTENDS EOI BY WRITING DUMMY PRUS                  *LEP57530
*                                                                      *LEP57540
************************************************************************LEP57550
IOMEOF    SPACE     2                                                   LEP57560
***       IOMEOF  (LFN)                                                 LEP57570
*                                                                       LEP57580
*         WRITE AN END-OF-FILE MARK AT CURRENT DEVICE POSITION          LEP57590
*                                                                       LEP57600
*         FORTRAN REFERENCE -                                           LEP57610
*                                                                       LEP57620
*         CALL   IOMEOF (LFN)                                           LEP57630
*                                                                       LEP57640
*         WHERE                                                         LEP57650
*                                                                       LEP57660
*         LFN       LOGICAL FILENAME                                    LEP57670
*                                                                       LEP57680
          ENTRY     IOMEOF                                              LEP57690
IOMEOF    BSSZ      1                                                   LEP57700
          SX2       0104B          R-BIT=0,EP-BIT=1,XP-BIT=0,FETL=4     LEP57710
          MX4       0                                                   LEP57720
          SX3       X2             DUMMY BUFFER ADDRESS                 LEP57730
          MX5       0                                                   LEP57740
          SX6       B0                                                  LEP57750
          RJ        =XFETSET$      ESTABLISH FET                        LEP57760
          WRITEF    FET,R          WRITE W/EOF MACRO                    LEP57770
          RJ        =XFETRET$      GET RET/AT CODES                     LEP57780
          EQ        IOMEOF         RETURN TO CALLING PROGRAM            LEP57790
IOMPRU    SPACE     2                                                   LEP57800
***       IOMPRU    (LFN)                                               LEP57810
*                                                                       LEP57820
*         OBTAIN LENGTH OF MASS STORAGE FILE IN PRUS                    LEP57830
*                                                                       LEP57840
*         FORTRAN REFERENCE -                                           LEP57850
*                                                                       LEP57860
*         NPRU =    IOMPRU (LFN)                                        LEP57870
*                                                                       LEP57880
*         WHERE                                                         LEP57890
*                                                                       LEP57900
*         LFN       LOGICAL FILENAME                                    LEP57910
*                                                                       LEP57920
*         IOMPRU    CURRENT FILE SIZE IN PRUS                           LEP57930
*                                                                       LEP57940
*         REMARK -  THE NOS PRU COUNT (AS RETURNED BY THE LENGTH CC)    LEP57950
*         IS ALWAYS ONE MORE THAN THE SCOPE COUNT (AS RETURNED BY       LEP57960
*         THE STATUS MACRO). NO REASONS FOR THIS DISCREPANCY ARE        LEP57970
*         KNOWN (WHEN DOES A CDC O/S EVER MAKES SENSE, ANYWAY).         LEP57980
*         THIS FUNCTION CORRECTS THE NOS COUNT BY SUBSTRACTING 1.       LEP57990
*                                                                       LEP58000
          ENTRY     IOMPRU                                              LEP58010
IOMPRU    BSS       1              ENTRY/EXIT                           LEP58020
          SB7       1              (B7) = 1                             LEP58030
          IFEQ      OS,SCOPE                                            LEP58040
          MX6       1                                            (SCOPE)LEP58050
          SA1       X1             (X1) = LFN                    (SCOPE)LEP58060
          LX6       38D            (X6) = LIST HEADER = 24/2,36/0(SCOPE)LEP58070
          MX0       42D                                          (SCOPE)LEP58080
          SA6       FET            PUT LIST HEADER IN FET(1)     (SCOPE)LEP58090
          BX7       X0*X1                                        (SCOPE)LEP58100
          MX6       0                                            (SCOPE)LEP58110
          SA7       A6+B7          STORE LFN IN FET(2)           (SCOPE)LEP58120
          SA6       A7+B7          CLEAR FET(3)                  (SCOPE)LEP58130
          STATUS    FET,3,R        ISSUE STATUS REQUEST          (SCOPE)LEP58140
          SA1       FET+2          (X1) = WORD WITH PRU COUNT    (SCOPE)LEP58150
          MX0       -24D                                         (SCOPE)LEP58160
          BX6       -X0*X1         MASK OUT PRU COUNT FIELD      (SCOPE)LEP58170
          ELSE                                                          LEP58180
          MX4       0                                              (NOS)LEP58190
          SX2       1002B                                          (NOS)LEP58200
          SX3       PAD                                            (NOS)LEP58210
          SX5       B0                                             (NOS)LEP58220
          MX6       0                                              (NOS)LEP58230
          RJ        =XFETSET$      ESTABLISH A FET                 (NOS)LEP58240
          SKIPEI    FET,R          POSITION FILE TO EOI            (NOS)LEP58250
          STATUS    FET,P          GET FNT/FST ENTRIES             (NOS)LEP58260
          SA1       FET+6          (X1) = FET(7) = FST ENTRY       (NOS)LEP58270
          MX0       -12D                                           (NOS)LEP58280
          AX1       12D            RIGHTJUSTIFY SECTOR COUNT FLD   (NOS)LEP58290
          BX6       -X0*X1         (X6) = CURRENT SECTOR NO.       (NOS)LEP58300
          AX1       12D            RIGHJUSTIFY CURRENT TRACK FLD   (NOS)LEP58310
          BX2       -X0*X1         (X2) = CURRENT TRACK NO.        (NOS)LEP58320
          AX1       12D            RIGHTJUSTIFY FIRST-TRACK FIELD  (NOS)LEP58330
          SX3       214D           (X3) = SECTORS PER TRACK        (NOS)LEP58340
          BX1       -X0*X1         (X1) = FIRST TRACK VALUE        (NOS)LEP58350
          IX2       X2-X1          (X2) = TRACK COUNT              (NOS)LEP58360
          SX4       B1             (X4) = 1                        (NOS)LEP58370
          DX2       X2*X3          CONVERT TRACK DIFF TO SECTORS   (NOS)LEP58380
          IX6       X2+X6          (X6) = SECTORS (PRU) COUNT      (NOS)LEP58390
          IX6       X6-X4          MAKE COUNT SCOPE COMPATIBLE     (NOS)LEP58400
          PL        X6,IOMPRU                                      (NOS)LEP58410
          MX6       0              IF COUNT NEGATIVE, SET (X6) = 0 (NOS)LEP58420
          ENDIF                                                         LEP58430
          EQ        IOMPRU         RETURN                               LEP58440
*                                                                       LEP58450
IOMRDR    SPACE     2                                                   LEP58460
***       IOMRDR    (LFN, A, N, LOCR, TYPEX)                            LEP58470
***       RD MS     (LFN, A, N, LOCR)                                   LEP58480
*                                                                       LEP58490
*         ENTRY TO READ A RECORD FROM AUXILIARY STORAGE                 LEP58500
*                                                                       LEP58510
*         FORTRAN REFERENCE -                                           LEP58520
*                                                                       LEP58530
*         CALL   IOMRDR  (LFN, A, N, LOCR, TYPEX)                       LEP58540
*                                                                       LEP58550
*                                                                       LEP58560
*         WHERE THE FUNCTION OF THE ARGUMENTS IS IDENTICAL TO           LEP58570
*         THOSE OF IOMWTR (SEE BELOW)                                   LEP58580
*                                                                       LEP58590
          ENTRY     IOMRDR                                              LEP58600
*         ENTRY     IOMRDR,RDMS                                         LEP58610
RDMS      BSS       1              STAGS-COMPATIBLE ENTRY POINY         LEP58620
          SA5       RDMS           FETCH RETURN INSTRUCTION             LEP58630
          SB7       1                                                   LEP58640
          BX7       X5                                                  LEP58650
          SA3       A1+B7          (X3) = ADDRESS(A)               (FTN)LEP58660
          SA4       A3+B7          (X4) = ADDRESS(N)               (FTN)LEP58670
          SA2       A4+B7          (X2) = ADDRESS(LOCR)            (FTN)LEP58680
          SA4       X4             (X4) = N                        (FTN)LEP58690
          SB4       X2             (B4) = ADDRESS(LOCR)            (FTN)LEP58700
          SA7       IOMRDR         STORE RETURN INSTR                   LEP58710
          NG        X4,IOMRDR      EXIT IF N LT 0                       LEP58720
          EQ        RDSAMS         TO SECTOR-ADDRESSABLE MS SECTION     LEP58730
*                                                                       LEP58740
IOMRDR    BSSZ      1              MAIN ENTRY POINT TO READ A RECORD    LEP58750
          SB7       1              (B7) = 1                             LEP58760
          SB6       B7+B7          (B6) = 2                             LEP58770
          SA4       A1+B6          (X4) = ADDRESS(N)               (FTN)LEP58780
          SA3       A1+B7          (X3) = ADDRESS(A)               (FTN)LEP58790
          SA5       A4+B6          (X5) = ADDRESS(TYPEX)           (FTN)LEP58800
          SA2       A4+B7          (X2) = ADDRESS(LOCR)            (FTN)LEP58810
          SA4       X4             (X4) = N                        (FTN)LEP58820
          SA5       X5             (X5) = TYPEX                    (FTN)LEP58830
          SB4       X2             (B4) = ADDRESS(LOCR)            (FTN)LEP58840
          SB5       X5             (B5) = TYPEX                         LEP58850
          NG        X4,IOMRDR      EXIT IF N LT 0                       LEP58860
          GT        B5,B6,RDECS    TO ECS-READ SECTION IF TYPEX = 3     LEP58870
          EQ        B5,B6,RDWAMS   TO WAMS SECTION IF TYPEX = 2         LEP58880
          LT        B5,B0,RDTAPE   TO TAPE-READ SECTION IF TYPEX LT 0   LEP58890
*                                                                       LEP58900
*         READ RECORD FROM SECTOR-ADDRESSABLE MASS STORAGE              LEP58910
*                                                                       LEP58920
RDSAMS    BSS       0                                                   LEP58930
          SX5       X4+77B         (X5) = N + (64-1), (64=PRU SIZE)     LEP58940
          SX2       1104B          R-BIT=1,EP-BIT=1,XP-BIT=0,FETL=4     LEP58950
          AX5       6              (X5) = (N+63)/64                     LEP58960
          SX6       B7             LIMIT = ADS(BUFFER)+NWXF+1           LEP58970
          LX5       6              (X5) = NWXF = 64*((N+63)/64)         LEP58980
          IX0       X5-X4          (X0) = NWXF-N = NWPAD                LEP58990
          BX4       X5             (X4) = NWXF FOR FET ASSEMBLY         LEP59000
          MX5       0              (X5) = 0  TO MARK READ CONDITION     LEP59010
          IX7       X3+X4          (X7) = ADDRESS(A)+NWXF               LEP59020
          SB2       X0             (B2) = NWPAD                         LEP59030
          SB5       X7             (B5) = ADDRESS(A(NWXF+1))            LEP59040
          RJ        =XFETSET$      ESTABLISH FET                        LEP59050
          SA4       B4             (X4) = LOCR = PRU ORDINAL            LEP59060
          SA1       CMSIZ          (X1) = CURRENT CM FL                 LEP59070
          BX6       X4             (X6) = LOCR                          LEP59080
          SA6       FET+6          PRU ORDINAL TO FET(7)                LEP59090
          NZ        X1,RDSAMS1     SKIP IF CMSIZ CONTAINS NZ VALUE      LEP59100
          MX7       0              ELSE CLEAR (X7) TO FLAG CMSIZ REQUESTLEP59110
          RJ        =XDMCMSZ$      AND OBTAIN CURRENT JOB SIZE          LEP59120
RDSAMS1   BSS       0                                                   LEP59130
          EQ        B2,RDSAMS4     OMIT PADDING PROCESSING IF NWPAD=0   LEP59140
          SB3       X1             (B3) = CMSIZ                         LEP59150
          SX7       B5             (X7) = ADDRESS(A(NWXF+1))            LEP59160
          GE        B3,B5,RDSAMS2  OMIT FL EXPANSION IF FL GE IN        LEP59170
          RJ        =XDMCMSZ$      ELSE EXPAND CM TO (X7) WORDS         LEP59180
RDSAMS2   BSS       0                                                   LEP59190
          SA7       PADDING-1      (A7) POINTS TO PADDING(0)            LEP59200
          SA2       B5             (A2) POINTS TO A(NWXF+1)             LEP59210
          SB3       B0             INITIALIZE WORD XFER COUNTER         LEP59220
RDSAMS3   BSS       0                                                   LEP59230
           SA2       A2-B7         (X2) = A(NWXF+1-J)                   LEP59240
           SB3       B3+B7         INCREMENT COUNTER                    LEP59250
           BX7       X2                                                 LEP59260
           SA7       A7+B7         STORE IN PADDING(J)                  LEP59270
           LT        B3,B2,RDSAMS3 CYCLE                                LEP59280
          SA5       A7             (A5) = EXIT (A7) FOR RESTORE LOOP    LEP59290
          SX5       A2             (X5) = EXIT (A2) FOR RESTORE LOOP    LEP59300
RDSAMS4   BSS       0                                                   LEP59310
          IFEQ      OS,NOS                                              LEP59320
          SX0       B2             SAVE (B2) = NWPAD IN (X0)       (NOS)LEP59330
          ENDIF                                                         LEP59340
          READNS    FET,R          READ IGNORING EOR                    LEP59350
          IFEQ      OS,NOS                                              LEP59360
          SB2       X0             RESTORE (B2) = NWPAD            (NOS)LEP59370
          ENDIF                                                         LEP59380
          RJ        =XFETRET$      GET RETURN DATA FROM FET             LEP59390
          EQ        B2,IOMRDR      SKIP PAD-RESTORE IF NWPAD = 0        LEP59400
          SA3       A5             (X3) = LAST WORD SAVED IN PADDING    LEP59410
          SB2       B2-B7                                               LEP59420
          BX6       X3                                                  LEP59430
          SA6       X5             RESTORE A(N+1)                       LEP59440
          LE        B2,IOMRDR      EXIT IF NWPAD = 1                    LEP59450
RDSAMS6   BSS       0                                                   LEP59460
           SA3       A3-B7         (X3) = NEXT SAVED WORD               LEP59470
           SB2       B2-B7         DECREMENT COUNTER                    LEP59480
           BX6       X3                                                 LEP59490
           SA6       A6+B7         RESTORE A(N+J)                       LEP59500
           GT        B2,RDSAMS6    CYCLE UNTIL (B2) = 0                 LEP59510
          EQ        IOMRDR         RETURN TO CALLING PROGRAM            LEP59520
*                                                                       LEP59530
*         READ RECORD FROM (SIMULATED) WORD-ADDRESSABLE                 LEP59540
*         MASS STORAGE DEVICE (NOT YET IMPLEMENTED)                     LEP59550
*                                                                       LEP59560
RDWAMS    BSS       0                                                   LEP59570
          EQ        WRWAMS         ISSUE DF MESSAGE AND ABORT           LEP59580
*                                                                       LEP59590
*         READ RECORD FROM TAPE                                         LEP59600
*                                                                       LEP59610
RDTAPE    BSS       0                                                   LEP59620
          SX2       0114B          R-BIT=0,EP-BIT=1,XP-BIT=1,FETL=4     LEP59630
          SX6       1000B          LIMIT = ADS(BUFFER)+N+1000B          LEP59640
          MX5       0              MARK READ CONDITION                  LEP59650
          RJ        =XFETSET$      ESTABLISH FET                        LEP59660
          READ      FET,R          STANDARD READ W/RECALL               LEP59670
          RJ        =XFETRET$      GET RETURN DATA FROM FET             LEP59680
          EQ        IOMRDR         RETURN TO CALLING PROGRAM            LEP59690
*                                                                       LEP59700
*         READ FROM EXTENDED CORE STORAGE                               LEP59710
*                                                                       LEP59720
RDECS     BSS       0                                                   LEP59730
          SA2       B4             (X2) = LOCR                          LEP59740
          SB1       A0                                                  LEP59750
          SA0       X3             (A0) = ADDRESS(A)                    LEP59760
          SB3       X4             (B3) = N                             LEP59770
          BX0       X2             (X0) = ECS SOURCE ADDRESS            LEP59780
          SX6       B3             (X6) = N                             LEP59790
          RE        B3             XMIT BLOCK                           LEP59800
          SA6       NWRDXF         SET NWRDXF                           LEP59810
          SA0       B1             RESTORE (A0)                         LEP59820
          EQ        IOMRDR         RETURN TO CALLING PROGRAM            LEP59830
*                                                                       LEP59840
IOMWTR    SPACE     2                                                   LEP59850
***       IOMWTR    (LFN, A, N, LOCR, TYPEX)                            LEP59860
***       WTMS      (LFN, A, N, LOCR)                                   LEP59870
*                                                                       LEP59880
*         ENTRY TO WRITE A RECORD ON AUXILIARY STORAGE                  LEP59890
*                                                                       LEP59900
*         FORTRAN REFERENCE -                                           LEP59910
*                                                                       LEP59920
*         CALL   IOMWTR  (LFN, A, N, LOCR, TYPEX)                       LEP59930
*         CALL   WT MS   (LFN, A, N, LOCR)                              LEP59940
*                                                                       LEP59950
*         WHERE                                                         LEP59960
*                                                                       LEP59970
*         LFN       LOGICAL FILENAME IF AUXILIARY STORAGE MEDIUM        LEP59980
*                   IS MASS STORAGE OR MAGNETIC TAPE.  IGNORED IF       LEP59990
*                   RECORD IS TO BE WRITTEN ON ECS (LCM).               LEP60000
*                                                                       LEP60010
*         A         FWA OF SOURCE ARRAY IN PRIMARY MEMORY               LEP60020
*                                                                       LEP60030
*         N         NUMBER OF WORDS TO TRANSMIT. N=0 IS ADMISSIBLE.     LEP60040
*                                                                       LEP60050
*         LOCR      RECORD ADDRESS ARGUMENT.  SIGNIFICANCE DEPENDS      LEP60060
*                   ON EQUIPMENT TYPE.                                  LEP60070
*                                                                       LEP60080
*                   SECTOR-ADDRESSABLE MASS STORAGE (TYPEX=0,1)         LEP60090
*                     LOCR = 0   WRITE NEW RECORD AT EOI.  UPON A       LEP60100
*                     SUCCESSFUL WRITE, THE SYSTEM RETURNS THE  REL     LEP60110
*                     SECTOR ADDRESS (RSA) OF THE RECORD IN LOCR.       LEP60120
*                     LOCR GT 0.  SPECIFIES RECORD REWRITE AT           LEP60130
*                     RELATIVE SECTOR ADDRESS (RSA) IN LOCR.            LEP60140
*                                                                       LEP60150
*                   WORD-ADDRESSABLE MASS STORAGE (TYPEX=2)  THIS       LEP60160
*                   MODE IS NOT PRESENTLY IMPLEMENTED.                  LEP60170
*                                                                       LEP60180
*                   MAGNETIC TAPE (TYPEX LT 0).  LOCR IS IGNORED        LEP60190
*                   AND RECORD XMISSION PROCEEDS AT CURRENT LOCATION.   LEP60200
*                                                                       LEP60210
*                   ECS/LCM (TYPEX=3). LOCR = FWA OF DESTINATION AREA.  LEP60220
*                                                                       LEP60230
*         TYPEX     DMGASP DEVICE TYPE INDEX (SEE DMGASP MANUAL)        LEP60240
*                                                                       LEP60250
*         NOTES -                                                       LEP60260
*         1.  ENTRY WTMS (PROVIDED FOR STAGS COMPATIBILITY) ASSUMES     LEP60270
*             TYPEX = 0, I.E. SECTOR-ADDRESSABLE MASS STORAGE.          LEP60280
*                                                                       LEP60290
*         2.  NO END-OF-RECORD IS MARKED WHEN WRITING ON A RANDOM       LEP60300
*             ACCESS DEVICE (TYPEX GE 0).  TAPE RECORDS ARE TERMINATED  LEP60310
*             BY AN EOR MARK.                                           LEP60320
*             (THIS M.O. SIMPLIFIES UNIVAC I/O SIMULATION)              LEP60330
*                                                                       LEP60340
          ENTRY     IOMWTR                                              LEP60350
*         ENTRY     IOMWTR,WTMS                                         LEP60360
WTMS      BSS       1              STAGS-COMPATIBLE ENTRY               LEP60370
          SA5       WTMS           FETCH RETURN RJ INSTRUCTION          LEP60380
          SB7       1              (B7) = 1                             LEP60390
          BX7       X5             (X7) = RET INSTR                     LEP60400
          SA3       A1+B7          (X3) = ADDRESS(A)               (FTN)LEP60410
          SA4       A3+B7          (X4) = ADDRESS(N)               (FTN)LEP60420
          SA2       A4+B7          (X2) = ADDRESS(LOCR)            (FTN)LEP60430
          SA4       X4             (X4) = N                        (FTN)LEP60440
          SB4       X2             (B4) = ADDRESS(LOCR)            (FTN)LEP60450
          SA7       IOMWTR         STORE RETURN INSTR                   LEP60460
          NG        X4,IOMWTR      EXIT IF N LT 0                       LEP60470
          EQ        WRSAMS         TO SECTOR-ADDRESSABLE MS SECTION     LEP60480
*                                                                       LEP60490
IOMWTR    BSSZ      1              MAIN ENTRY POINT TO WRITE A RECORD   LEP60500
          SB7       1              (B7) = 1                             LEP60510
          SB6       B7+B7          (B6) = 2                             LEP60520
          SA4       A1+B6          (X4) = ADDRESS(N)               (FTN)LEP60530
          SA3       A1+B7          (X3) = ADDRESS(A)               (FTN)LEP60540
          SA5       A4+B6          (X5) = ADDRESS(TYPEX)           (FTN)LEP60550
          SA2       A4+B7          (X2) = ADDRESS(LOCR)            (FTN)LEP60560
          SA4       X4             (X4) = N                        (FTN)LEP60570
          SA5       X5             (X5) = TYPEX                    (FTN)LEP60580
          SB4       X2             (B4) = ADDRESS(LOCR)            (FTN)LEP60590
          SB5       X5             (B5) = TYPEX                         LEP60600
          NG        X4,IOMWTR      EXIT IF N LT 0                       LEP60610
          GT        B5,B6,WRECS    TO ECS-WRITE SECTION IF TYPEX = 3    LEP60620
          EQ        B5,B6,WRWAMS   TO WAMS SECTION IF TYPEX = 2         LEP60630
          LT        B5,B0,WRTAPE   TO TAPE-WRITE SECTION IF TYPEX LT 0  LEP60640
*                                                                       LEP60650
*         WRITE RECORD ON SECTOR-ADDRESSABLE MASS STORAGE               LEP60660
*                                                                       LEP60670
WRSAMS    BSS       0                                                   LEP60680
          SX5       X4+77B         (X5) = N + (PRUSIZ-1)                LEP60690
          SX2       1104B          R-BIT=1,EP-BIT=1,XP-BIT=0,FETL=4     LEP60700
          AX5       6              (X5) = (N+63)/64                     LEP60710
          SX6       B7             MARK  LIMIT = ADS(BUFFER)+NWXF+1     LEP60720
          LX5       6              (X5) = NWXF = 64*((N+63)/64)         LEP60730
          IX0       X5-X4          (X0) = NWXF-N = NWPAD                LEP60740
          BX4       X5             (X4) = NWXF FOR FET ASSEMBLY         LEP60750
          IX7       X3+X5          (X7) = ADDRESS(A)+NWXF               LEP60760
          SB2       X0             (B2) = NWPAD                         LEP60770
          SB5       X7             (B5) = ADDRESS(A(NWXF+1))            LEP60780
          RJ        =XFETSET$      ESTABLISH FET                        LEP60790
          SA4       B4             (X4) = LOCR                          LEP60800
          SX0       B7             (X0) = 1                             LEP60810
          SX6       B4             (X6) = ADDRESS(LOCR)                 LEP60820
          MX7       0              (X7) = 0 TO FLAG DMCMSZ REQUEST      LEP60830
          ZR        X4,WRSAMS1     TEST FOR LOCR = 0 (WRITE AT EOI)     LEP60840
          IFEQ      OS,SCOPE                                            LEP60850
          BX6       X4             (X6) = LOCR                   (SCOPE)LEP60860
          ELSE                                                          LEP60870
          LX0       29D            (X0) = 30/0,1/1,29/0            (NOS)LEP60880
          BX6       X4+X0          (X6) = LOCR + REWRITE BIT       (NOS)LEP60890
          ENDIF                                                         LEP60900
WRSAMS1   BSS       0                                                   LEP60910
          SA1       CMSIZ          (X1) = CURRENT CM FL                 LEP60920
          SA6       FET+6          ADS(LOCR)/LOCR TO FET(7)             LEP60930
          NZ        X1,WRSAMS2                                          LEP60940
          RJ        =XDMCMSZ$      GET CURRENT CM SIZE                  LEP60950
WRSAMS2   BSS       0                                                   LEP60960
          EQ        B2,WRSAMS5     OMIT PADDING PROCESSING IF NWPAD=0   LEP60970
          SB3       X1             (B3) = CMSIZ                         LEP60980
          SX7       B5             (X7) = ADDRESS(A(NWXF+1))            LEP60990
          GE        B3,B5,WRSAMS3  OMIT FL EXPANSION IF FL GE IN        LEP61000
          RJ        =XDMCMSZ$      ELSE EXPAND CM FL TO (X7) WORDS      LEP61010
WRSAMS3   BSS       0                                                   LEP61020
WRSAMS5   BSS       0                                                   LEP61030
          NZ        X4,WRSAMS6     BRANCH ON LOCR = ZR/NZ               LEP61040
          WRITE     FET,R          WRITE MACRO                          LEP61050
          EQ        WRSAMS7                                             LEP61060
WRSAMS6   BSS       0                                                   LEP61070
          REWRITE   FET,R          REWRITE MACRO                        LEP61080
WRSAMS7   BSS       0                                                   LEP61090
          RJ        =XFETRET$      OBTAIN FET STATUS DATA               LEP61100
          SA2       EOICOD         (X2) = EOI CODE                      LEP61110
          SA3       OUTMIN         (X3) = OUT-IN                        LEP61120
          MX6       42D            (X6) = FILENAME MASK                 LEP61130
          SB5       X2             (B5) = EOI CODE                      LEP61140
          ZR        X3,WRSAMS8     IF IN=OUT, WRITING IS COMPLETE       LEP61150
          SA1       FET            (X1) = FET HEADER WORD               LEP61160
          NE        B5,B7,WRSAMS8  TEST FOR TRUNCATION ON HITTING EOI   LEP61170
          SX2       B6+B7          (X2) = 3                             LEP61180
          BX6       X6*X1          MASK OUT LFN IN (X6)                 LEP61190
          BX6       X6+X2          SET INTERLOCK/BINARY-MODE BITS       LEP61200
          MX7       0                                                   LEP61210
          SA6       A1             RESTORE FET(1) TO VIRGIN CONDITION   LEP61220
          SA7       NWRDXF         RESET NWRDXF TO ZERO                 LEP61230
          WRITE     FET,R          ISSUE FINAL WRITE TO MOVE EOI        LEP61240
          RJ        =XFETRET$      GET RETURN PARAMETERS FROM FET       LEP61250
WRSAMS8   BSS       0                                                   LEP61260
          EQ        IOMWTR         RETURN TO CALLING PROGRAM            LEP61270
*                                                                       LEP61280
*         WRITE ON WORD-ADDRESSABLE MASS STORAGE (NOT IMPLEMENTED)      LEP61290
*                                                                       LEP61300
WRWAMS    BSS       0                                                   LEP61310
          MESSAGE   WAMSG,,R                                            LEP61320
          ABORT                                                         LEP61330
WAMSG     DIS       4,WORD-ADDRESSABLE MODE NOT AVAILABLE               LEP61340
          BSSZ      1                                                   LEP61350
*                                                                       LEP61360
*         WRITE RECORD ON TAPE                                          LEP61370
*                                                                       LEP61380
WRTAPE    BSS       0                                                   LEP61390
          SX2       0114B          R-BIT=0,EP-BIT=1,XP-BIT=1,FETL=4     LEP61400
          SX6       1000B          LIMIT = ADS(BUFFER)+N+1000B          LEP61410
          SB3       X4             (B3) = N                             LEP61420
          BX5       X4             X5 = N (WRITE CONDITION)             LEP61430
          RJ        =XFETSET$      ESTABLISH FET                        LEP61440
          IFEQ      OS,SCOPE                                            LEP61450
          WRITER    FET,,R         WRITE W/EOR AND RECALL        (SCOPE)LEP61460
          ELSE                                                          LEP61470
          WRITER    FET,R          WRITE W/EOR AND RECALL          (NOS)LEP61480
          ENDIF                                                         LEP61490
          RJ        =XFETRET$      GET RETURN PARAMETERS FROM FET       LEP61500
          EQ        IOMWTR         RETURN TO CALLING PROGRAM            LEP61510
*                                                                       LEP61520
*         WRITE ON EXTENDED CORE (LARGE MEMMORY)                        LEP61530
*                                                                       LEP61540
WRECS     BSS       0                                                   LEP61550
          SA2       B4             (X2) = LOCR                          LEP61560
          SB1       A0                                                  LEP61570
          SB3       X4             (B3) = N                             LEP61580
          SA0       X3             (A0) = ADDRESS(A)                    LEP61590
          SX6       B3             (X6) = N                             LEP61600
          BX0       X2             (X0) = ECS DESTINATION ADDRESS       LEP61610
          WE        B3             XMIT N-WORD BLOCK (B3) = N           LEP61620
          SA6       NWRDXF         SET NWRDXF                           LEP61630
          SA0       B1             RESTORE (A0)                         LEP61640
          EQ        IOMWTR         RETURN                               LEP61650
*                                                                       LEP61660
IOMXEI    SPACE     2                                                   LEP61670
***       IOMXEI    (LFN, NPRUS)                                        LEP61680
*                                                                       LEP61690
*         EXTEND EOI OF MASS STORAGE FILE BY WRITING A SPECIFIED        LEP61700
*         NUMBER OF DUMMY (ZERO FILLED) PHYSICAL RECORD UNITS (PRUS).   LEP61710
*         THIS IS NEEDED FOR UNIVAC SIMULATION ON THE CDC.              LEP61720
*                                                                       LEP61730
*         FORTRAN REFERENCE -                                           LEP61740
*                                                                       LEP61750
*         CALL      IOMXEI (LFN, NPRUS)                                 LEP61760
*                                                                       LEP61770
*         WHERE                                                         LEP61780
*                                                                       LEP61790
*         LFN       LOGICAL FILE NAME                                   LEP61800
*                                                                       LEP61810
*         NPRUS     NO. OF PRUS TO BE WRITTEN (MAX 2**17)               LEP61820
*                                                                       LEP61830
*                                                                       LEP61840
*                                                                       LEP61850
          ENTRY     IOMXEI                                              LEP61860
IOMXEI    BSS       1              ENTRY/EXIT                           LEP61870
          SB7       1              (B7) = 1                             LEP61880
          SA5       A1+B7          (X5) = ADDRESS(NPRUS)           (FTN)LEP61890
          SA5       X5             (X5) = NPRUS                    (FTN)LEP61900
          BX6       X1                                                  LEP61910
          SA6       LFNADS         SAVE ADDRESS(LFN)                    LEP61920
          BX7       X5                                                  LEP61930
          SA7       A6+B7          SAVE NPRUS                           LEP61940
          BX1       X5                                                  LEP61950
          RJ        =XNCOCTL$      ENCODE NPRUS IN (X6)                 LEP61960
          SA2       XEIMESG                                             LEP61970
          SA6       ASTMSG+3                                            LEP61980
          SA3       A2+B7                                               LEP61990
          SA4       A3+B7                                               LEP62000
          LX7       X3                                                  LEP62010
          BX6       X4                                                  LEP62020
          SA7       A6-B7                                               LEP62030
          SA6       A6+B7                                               LEP62040
          BX7       X2                                                  LEP62050
          SA7       A7-B7                                               LEP62060
          RJ        =XIOMESSG      PRINT MESSAGE                        LEP62070
          SA1       LFNADS         RESTORE (X1) = LFN ADDRESS           LEP62080
          SA5       PRUXEI         RESTORE (X5) = NPRUS                 LEP62090
          SX2       1104B                                               LEP62100
          SX3       BUFFER         (X3) = ADDRESS(BUFFER)               LEP62110
          SX4       BUFSIZ         (X4) = BUFFER SIZE (WORDS)           LEP62120
          BX5       X4             (X5) = (X4) FOR WRITE MODE           LEP62130
          MX6       0                                                   LEP62140
          SB4       X4             (B4) = BUFSIZ                        LEP62150
          RJ        =XFETSET$      ESTABLISH FET                        LEP62160
          MX6       0              CLEAR (X6)                           LEP62170
          SB2       B7             INITIALIZE COUNTER (B2)=1            LEP62180
          SA6       BUFFER         INITIALIZE (A6)                      LEP62190
XTEOI1     BSS       0                                                  LEP62200
           SB2       B2+B7         COUNT                                LEP62210
           SA6       A6+B7         CLEAR BUFFER WORD                    LEP62220
           LT        B2,B4,XTEOI1  CYCLE UNTIL BUFFER IS CLEARED        LEP62230
*                                                                       LEP62240
XTEOI2     BSS       0                                                  LEP62250
           SA5       PRUXEI        (X5) = REMAINING PRUS TO WRITE       LEP62260
           SA1       FET           (X1) = FET HEADER                    LEP62270
           MX0       44D                                                LEP62280
           SB3       BUFPRU                                             LEP62290
           SB5       X5            (B5) = REMAINING PRUS                LEP62300
           LX0       2             (X0) = MASK FOR LFN AND MODE/ITLOCK  LEP62310
           SX6       B5-B3         DECREMENT REM.PRU COUNTER            LEP62320
           BX7       X0*X1         (X7) = FET HEADER WORD               LEP62330
           SA6       PRUXEI                                             LEP62340
           SA7       A1            STORE FET HEADER                     LEP62350
           SX6       B3            ASSUME FULL BUFFER WRITE             LEP62360
           SX7       BUFFER-1      (X7) = ADDRESS(BUFFER-1)             LEP62370
           LT        B5,IOMXEI     EXIT IF (B5) LE 0                    LEP62380
           GE        B5,B3,XTEOI3  TEST FOR LAST PARTIAL WRITE          LEP62390
           SX6       B5                                                 LEP62400
XTEOI3     BSS       0                                                  LEP62410
           SA7       FET+6         ADDRESS(BUFFER-1) TO FET(7)          LEP62420
           SX7       X7+B7         (X7) = ADDRESS(BUFFER)               LEP62430
           LX6       6             CONVERT PRUS TO WORDS                LEP62440
           SA6       NWXWRT        TO GET CORRECT NWRDXF                LEP62450
           SA7       FET+3         RESET (OUT) = ADDRESS(BUFFER)        LEP62460
           IX6       X6+X7         (X6) = ADDRESS(BUFFER)+NWXF          LEP62470
           SA6       A7-B7         RESET (IN)                           LEP62480
           WRITE     FET,R         WRITE BUFFER                         LEP62490
           RJ        =XFETRET$     GET FET RETURN DATA                  LEP62500
           NZ        X1,IOMXEI     ABANDON PROCESS IF ERROR             LEP62510
           EQ        XTEOI2        CYCLE                                LEP62520
XEIMESG   DIS       3,EOI TO BE XTENDED BY   PRUS                       LEP62530
          SPACE     3                                                   LEP62540
          END                                                           LEP62550
*DECK       IOMFAP                                                      LEP62560
* =DECK      IOMFAP      IOMFAP      ASSEMBLY                           LEP62570
          IDENT     IOMFAP                                              LEP62580
FILACT    TITLE     FILE ACTIVITY AND POSITIONING OPERATIONS            LEP62590
*CALL       IOMACTL                                                     LEP62600
          IFEQ      OS,NOS         *                                    LEP62610
************************************                               (NOS)LEP62620
*    EXTERNAL TEXT COMMON DECKS    *                               (NOS)LEP62630
************************************                               (NOS)LEP62640
*         LIST      X              *                               (NOS)LEP62650
          XTEXT     COMCSYS        *  SYSTEM REQUEST ROUTINES      (NOS)LEP62660
          XTEXT     COMCCIO        *  I/O REQUEST PROCESSOR        (NOS)LEP62670
          ENDIF                    *                                    LEP62680
************************************                                    LEP62690
COMMON    SPACE     2                                                   LEP62700
***       COMMON BLOCK DECLARATION                                      LEP62710
*                                                                       LEP62720
* =PROCEDURE CDMASTA                                                    LEP62730
*CALL        CDMASTA                                                    LEP62740
          USE       0                                                   LEP62750
          SPACE     3                                                   LEP62760
************************************************************************LEP62770
*                                                                      *LEP62780
*         FILE ACTIVITY FUNCTIONS PROVIDE CONTROL OVER DYNAMIC         *LEP62790
*         ASSIGNMENT OF PERIPHERAL EQUIPMENT, OPENING, CLOSING         *LEP62800
*         ERASING, AND POSITIONING OF LOGICAL/ILLOGICAL FILES          *LEP62810
*                                                                      *LEP62820
************************************************************************LEP62830
*                                                                      *LEP62840
*         PROGRAMMED BY C.A. FELIPPA, NOV 1975                         *LEP62850
*                                                                      *LEP62860
*         UPDATE -  NOV 1977                                           *LEP62870
*                                                                      *LEP62880
*         A FUNCTION SUMMARY FOLLOWS.                                  *LEP62890
*                                                                      *LEP62900
*         BSKIPR    BACKWARD SKIP LOGICAL RECORDS                      *LEP62910
*                                                                      *LEP62920
*         BSKIPF    BACKWARD SKIP FILES                                *LEP62930
*                                                                      *LEP62940
*         FSKIPR    FORWARD SKIP  LOGICAL RECORDS                      *LEP62950
*                                                                      *LEP62960
*         FSKIPF    FORWARD SKIP  FILES                                *LEP62970
*                                                                      *LEP62980
*         IOMCLS    CLOSES A LOGICAL FILE WITH RETURN.                 *LEP62990
*                                                                      *LEP63000
*         IOMEVT    DISCARDS CONTENTS OF FILE. LOGICAL FILENAME        *LEP63010
*                   REMAINS ATTACHED TO JOB CONTROL POINT.             *LEP63020
*                                                                      *LEP63030
*         IOMOPN    OPENS A LOGICAL FILE.                              *LEP63040
*                                                                      *LEP63050
*         IOMPOD    POSITIONS DIRECT ACCESS DEVICE  ACCORDING TO       *LEP63060
*                   DMGASP LOCATION PARAMETERS                         *LEP63070
*                                                                      *LEP63080
*         IOMPOT    POSITIONS MAGNETIC TAPE DEVICE ACCORDING TO        *LEP63090
*                   DMGASP LOCATION PARAMETERS                         *LEP63100
*                                                                      *LEP63110
*         IOMREW    POSITION FILE TO BOI (REWIND)                      *LEP63120
*                                                                      *LEP63130
*         IOMRMT    REQUESTS MAGNETIC TAPE ASSIGNMENT                  *LEP63140
*                   (PRESENTLY DEACTIVATED)                            *LEP63150
*                                                                      *LEP63160
************************************************************************LEP63170
IOMCLS    SPACE     2                                                   LEP63180
***       IOMCLS  (LFN)                                                 LEP63190
*                                                                       LEP63200
*         ENTRY POINT TO CLOSE A LOGICAL FILE. THIS OPERATION           LEP63210
*         TERMINATES FILE ACTIVITY.                                     LEP63220
*                                                                       LEP63230
*         FORTRAN REFERENCE -                                           LEP63240
*                                                                       LEP63250
*         CALL    IOMCLS  (LFN)                                         LEP63260
*                                                                       LEP63270
*         WHERE                                                         LEP63280
*                                                                       LEP63290
*         LFN       LOGICAL FILENAME                                    LEP63300
*                                                                       LEP63310
          ENTRY     IOMCLS                                              LEP63320
IOMCLS    BSS       1              ENTRY/EXIT POINT                     LEP63330
          SX2       0104B          R-BIT=0,EP-BIT=1,XP-BIT=0,FETL=4     LEP63340
          MX4       0              N = 0                                LEP63350
          SX3       X1             DUMMY BUFFER ADDRESS                 LEP63360
          MX5       0                                                   LEP63370
          SX6       B0                                                  LEP63380
          RJ        =XFETSET$      ESTABLISH FET                        LEP63390
+         SA2       =7HRETURN,                                          LEP63400
          RJ        FAMESG         PRINT INFORMATIVE MESSAGE            LEP63410
          CLOSE     FET,RETURN,R   CLOSE WITH RETURN                    LEP63420
          SA5       IOMCLS         FETCH RETURN INSTRUCTION             LEP63430
          EQ        FAEXIT         TO EXIT SECTION                      LEP63440
*                                                                       LEP63450
IOMEVT    SPACE     2                                                   LEP63460
***       IOMEVT  (LFN)                                                 LEP63470
*                                                                       LEP63480
*         ENTRY POINT TO EVICT (ERASE IN UNIVAC PARLANCE) A FILE        LEP63490
*                                                                       LEP63500
*         FORTRAN REFERENCE -                                           LEP63510
*                                                                       LEP63520
*         CALL   IOMEVT  (LFN)                                          LEP63530
*                                                                       LEP63540
*         WHERE                                                         LEP63550
*                                                                       LEP63560
*         LFN       LOGICAL FILE NAME.  CONTENTS OF LFN ARE             LEP63570
*                   DISCARDED. FILE IS NOT RELEASED FROM JOB.           LEP63580
*                                                                       LEP63590
          ENTRY     IOMEVT                                              LEP63600
IOMEVT    BSSZ      1              ENTRY/EXIT POINT                     LEP63610
          SX2       0104B          R-BIT=0,EP-BIT=1,XP-BIT=0,FETL=4     LEP63620
          MX4       0              N = 0                                LEP63630
          SX3       X1             DUMMY BUFFER ADDRESS                 LEP63640
          MX5       0                                                   LEP63650
          SX6       B0                                                  LEP63660
          RJ        =XFETSET$      ESTABLISH FET                        LEP63670
+         SA2       =7HEVICT,                                           LEP63680
          RJ        FAMESG         PRINT INFORMATIVE MESSAGE            LEP63690
          EVICT     FET,R          EVICT MACRO                          LEP63700
          SA5       IOMEVT         FETCH RETURN INSTRUCTION             LEP63710
          EQ        FAEXIT         TO EXIT SECTION                      LEP63720
*                                                                       LEP63730
IOMOPN    SPACE     2                                                   LEP63740
***       IOMOPN  (LFN)                                                 LEP63750
*                                                                       LEP63760
*         ENTRY POINT TO OPEN A FILE. THIS FUNCTION IS PRIMARILY        LEP63770
*         DESIGNED FOR ACQUIRING DEVICE ATTRIBUTE INFORMATION           LEP63780
*                                                                       LEP63790
*         FORTRAN REFERENCE -                                           LEP63800
*                                                                       LEP63810
*         CALL      IOMOPN  (LFN)                                       LEP63820
*                                                                       LEP63830
*         WHERE                                                         LEP63840
*                                                                       LEP63850
*         LFN       LOGICAL FILENAME  (1-7 CHARS, LJ ZEROFILLED)        LEP63860
*                   ON RETURN, FNT POINTER INSERTED IN BITS 0-11        LEP63870
*                                                                       LEP63880
*         VALUES RETURNED IN COMMON BLOCK /CDMAST/ INCLUDE              LEP63890
*         DEVTYP    CDC DEVICE CODE (12 BITS)                           LEP63900
*         PRUSIZ    PRU SIZE FOR DEVICE TO WHICH LFN IS ASSIGNED        LEP63910
*         FNTPNT    FNT POINTER, INSERTED IN LOW 12 BITS OF LFN         LEP63920
*                                                                       LEP63930
          ENTRY     IOMOPN                                              LEP63940
IOMOPN    BSSZ      1              ENTRY/EXIT POINT                     LEP63950
          MX4       0              N = 0                                LEP63960
          SX2       0104B          R-BIT=0,EP-BIT=1,XP-BIT=0,FETL=4     LEP63970
          MX5       0                                                   LEP63980
          BX3       X1             DUMMY BUFFER ADDRESS                 LEP63990
          SX6       B0                                                  LEP64000
          RJ        =XFETSET$      ESTABLISH FET                        LEP64010
          BX7       X1                                                  LEP64020
          SA7       LFNADS         SAVE LFN ADDRESS                     LEP64030
+         SA2       =5HOPEN,                                            LEP64040
          RJ        FAMESG         PRINT INFORMATIVE MESSAGE            LEP64050
          OPEN      FET,,R         ISSUE OPEN MACRO                     LEP64060
          SA1       LFNADS         (X1) = LFN ADDRESS                   LEP64070
          SA2       FET+1          (X2) = FET(2)                        LEP64080
          SB7       B1                                                  LEP64090
          MX0      -12D                                                 LEP64100
          SA3       X1             (X3) = LFN                           LEP64110
          SA4       FET+4          (X4) = FET(5)                        LEP64120
          LX2       12D            RIGHTJUSTIFY DEVICE-TYPE FIELD       LEP64130
          LX4       12D            RIGHTJUSTIFY FNT POINTER             LEP64140
          BX6      -X0*X2          EXTRACT DEVICE TYPE                  LEP64150
          BX7      -X0*X4          EXTRACT FNT POINTER                  LEP64160
          SA6       DEVTYP                                              LEP64170
          MX0       42D                                                 LEP64180
          BX3       X0*X3          CLEAR BITS FOLLOWING LFN             LEP64190
          LX4       30D            RIGHTJUSTIFY PRU SIZE FIELD          LEP64200
          BX6       X3+X7          INSERT FNT POINTER                   LEP64210
          SA6       A3             STORE (LFN/FNTPNT)                   LEP64220
          MX0      -15D                                                 LEP64230
          BX6      -X0*X4                                               LEP64240
          SA6       PRUSIZ                                              LEP64250
          SA5       IOMOPN                                              LEP64260
          EQ        FAEXIT         TO EXIT SECTION                      LEP64270
IOMPOD    SPACE     2                                                   LEP64280
***       IOMPOD    (CDLOC, LCARG1, LCARG2, SECTOR)                     LEP64290
*                                                                       LEP64300
*         ESTABLISH NEW POSITION OF DIRECT ACCESS DEVICE                LEP64310
*                                                                       LEP64320
*         FORTRAN REFERENCE -                                           LEP64330
*                                                                       LEP64340
*         CALL      IOMPOD   (CDLOC, LCARG1, LCARG2, SECTOR)            LEP64350
*                                                                       LEP64360
*         WHERE                                                         LEP64370
*                                                                       LEP64380
*         CDLOC     ON ENTRY, CURRENT DEVICE LOCATION (SECTORS)         LEP64390
*                   ON EXIT,  UPDATED DEVICE LOCATION  (SECTORS)        LEP64400
*                                                                       LEP64410
*         LCARG1    FIRST LOCATION ARGUMENT IN DMPAST                   LEP64420
*                                                                       LEP64430
*         LCARG2    SECOND LOCATION ARGUMENT IN DMPAST                  LEP64440
*                                                                       LEP64450
*         SECTOR    DEVICE SECTOR SIZE IN WORDS                         LEP64460
*                                                                       LEP64470
          ENTRY     IOMPOD                                              LEP64480
POSDAD    BSS       0                                                   LEP64490
IOMPOD    BSSZ      1              ENTRY/EXIT                           LEP64500
          SB7       1              (B7) = 1                             LEP64510
          SB6       B7+B7          (B6) = 2                             LEP64520
          SA2       A1+B7                                          (FTN)LEP64530
          SA3       A1+B6                                          (FTN)LEP64540
          SA4       A2+B6                                          (FTN)LEP64550
          SA1       X1             (X1) = CDLOC                    (FTN)LEP64560
          SA2       X2             (X2) = LCARG1                   (FTN)LEP64570
          SA3       X3             (X3) = LCARG2                   (FTN)LEP64580
          SA4       X4             (X4) = SECTOR                   (FTN)LEP64590
          BX7       X2             (X7) = LCARG1                        LEP64600
          SB3       X3             (B3) = LCARG2                        LEP64610
          SB4       X4             (B4) = SECTOR                        LEP64620
          BX6       X2                                                  LEP64630
          EQ        B3,PDAD4       IF LCARG2=0, CDLOC=LCARG1 AND EXIT   LEP64640
          AX2       60D            (X2) = EXTENDED SIGN OF LCARG1       LEP64650
          BX6       X7-X2          (X6) = IABS(LCARG1)                  LEP64660
          EQ        B4,B7,PDAD2    IF SECTOR=1, OMIT CONVERSION         LEP64670
          SX6       X6+77B                                              LEP64680
          AX6       6              (X6) = COVERING SECTOR COUNT (CSC)   LEP64690
PDAD2     PL        X7,PDAD3                                            LEP64700
          BX6       -X6            RESTORE LCARG1 SIGN                  LEP64710
PDAD3     SA6       A1             SET CDLOC = COV.SECTOR COUNT (SIGNED)LEP64720
          GT        B3,IOMPOD      EXIT IF ABSOLUTE POSITIONING         LEP64730
          IX6       X6+X1          ELSE (X6) = CDLOC + CSC              LEP64740
PDAD4     SA6       A1             SET NEW LOCATION                     LEP64750
          EQ        IOMPOD         EXIT                                 LEP64760
*                                                                       LEP64770
IOMPOT    SPACE     2                                                   LEP64780
***       IOMPOT    (LFN, CDLOC, NEWLOC)                                LEP64790
*                                                                       LEP64800
*         POSITION MAGNETIC TAPE DEVICE THROUGH THE                     LEP64810
*         DMGASP LOCATION PARAMETER                                     LEP64820
*                                                                       LEP64830
*         FORTRAN REFERENCE -                                           LEP64840
*                                                                       LEP64850
*         CALL      IOMPOT  (LFN, CDLOC, NEWLOC)                        LEP64860
*                                                                       LEP64870
*         WHERE                                                         LEP64880
*                                                                       LEP64890
*         LFN       LOGICAL FILENAME OF TAPE DEVICE                     LEP64900
*                                                                       LEP64910
*         CDLOC     ON ENTRY, CURRENT DEVICE LOCATION.                  LEP64920
*                   ON EXIT, CDLOC=NEWLOC IF NO ABNORMAL                LEP64930
*                   CONDITION IS DETECTED, ELSE CDLOC EXITS             LEP64940
*                   AT LAST ERROR FREE POSITION                         LEP64950
*                                                                       LEP64960
*         NEWLOC    DESIRED LOCATION                                    LEP64970
*                                                                       LEP64980
*                                                                       LEP64990
          ENTRY     IOMPOT                                              LEP65000
POSTAP    BSS       0                                                   LEP65010
IOMPOT    BSSZ      1              ENTRY POINT                          LEP65020
          SX2       0114B          R-BIT=0,E-BIT=1,XP-BIT=1,FETL=4      LEP65030
          BX3       X1             DUMMY BUFFER ADDRESS                 LEP65040
          SX4       B0             N=0                                  LEP65050
          MX5       0                                                   LEP65060
          SX6       X2             DUMMY BUFFER EXTENT                  LEP65070
          RJ        =XFETSET$      ESTABLISH FET                        LEP65080
          SA2       A1+B7          (X2) = ADDRESS(CDLOC)           (FTN)LEP65090
          SA3       A1+B6          (X3) = ADDRESS(NEWLOC)          (FTN)LEP65100
          SA2       X2             (X2) = CDLOC                    (FTN)LEP65110
          SA3       X3             (X3) = NEWLOC                   (FTN)LEP65120
          IX7       X3-X2          (X7) = NEWLOC-CDLOC                  LEP65130
          ZR        X7,IOMPOT      EXIT IF NEWLOC = CDLOC               LEP65140
          MX5       18D                                                 LEP65150
          AX7       12D            (X7) = MOVFIL = FILES TO MOVE        LEP65160
          LX5       36D            (X5) = MASK FOR FILE/REC COUNT       LEP65170
          ZR        X7,TAPOS4                                           LEP65180
*                                                                       LEP65190
*         POSITIONING BY FILES                                          LEP65200
*                                                                       LEP65210
          AX2       12D            (X2) = CDFIL                         LEP65220
          AX3       12D            (X3) = NEWFIL                        LEP65230
          PL        X7,TAPOS2                                           LEP65240
          BX7       -X7                                                 LEP65250
          SB3        X3            (B3) = NEWFIL                        LEP65260
          SB2        X7            (B2) = MOVFIL                        LEP65270
          GT        B3,B2,TAPOS2   TO BACKSKIP FILE SECTION IF          LEP65280
          REWIND    FET,R          REWIND TAPE                          LEP65290
          SA1       FET            FETCH FET HEADER                     LEP65300
          MX0       42D                                                 LEP65310
          MX6       0              (X6) = 0                             LEP65320
          BX1       X0*X1          CLEAR REO/RTN FIELD                  LEP65330
          SX5       B6+B7          (X5) = 3                             LEP65340
          SA6       A2             SET CDLOC = 0                        LEP65350
          BX7       X1+X5          SET FILE MODE/INTERLOCK BITS         LEP65360
          SA7       A1             RESTORE FET HEADER                   LEP65370
          EQ        B3,B0,TAPOS3   OMIT FORWARD SKIP IF NEWFIL=0        LEP65380
          SX7       B3             SET MOVFIL = NEWFIL                  LEP65390
*                                                                       LEP65400
TAPOS1    BSS       0                                                   LEP65410
          SA4       FSFMAC+1       FETCH OPERATION DESCRIPTOR           LEP65420
          LX7       18D            ROTATE MOVFIL                        LEP65430
          BX4       X4*X5          CLEAR FILE COUNT FIELD (N)           LEP65440
          BX6       X4+X7          INSERT MOVFIL                        LEP65450
          SA6       A4             STORE OP DESCRIPTOR                  LEP65460
FSFMAC    SKIPF     FET,,17B,R     FORWARD SKIP FILES                   LEP65470
          EQ        TAPOS3                                              LEP65480
TAPOS2    SA4       BSFMAC+1       FETCH OP DESCRIPTOR                  LEP65490
          LX7       18D            ROTATE FILE COUNT                    LEP65500
          BX4       X4*X5          CLEAR FILE COUNT FIELD               LEP65510
          BX6       X4+X7                                               LEP65520
          SA6       A4                                                  LEP65530
BSFMAC    SKIPB     FET,,17B,R     BACKSKIP FILES                       LEP65540
TAPOS3    LX3       12D            CDLOC = 4096*(NEWFIL-1)              LEP65550
          BX6       X3                                                  LEP65560
          SA6       A2             UPDATE CDLOC                         LEP65570
*                                                                       LEP65580
*         POSITION TAPE BY RECORDS                                      LEP65590
*                                                                       LEP65600
TAPOS4    BSS       0                                                   LEP65610
          SA2       A2                                                  LEP65620
          SA3       A3                                                  LEP65630
          SA1       FET                                                 LEP65640
          MX0       42D                                                 LEP65650
          BX1       X0*X1                                               LEP65660
          BX6       X1+X3                                               LEP65670
          SA6       A1                                                  LEP65680
          MX0       -12D                                                LEP65690
          IX7       X3-X2                                               LEP65700
          BX7       -X0*X7                                              LEP65710
          ZR        X7,TAPOS6                                           LEP65720
          PL        X7,TAPOS5                                           LEP65730
          SA4       BSRMAC+1                                            LEP65740
          BX7       -X7                                                 LEP65750
          LX7       18D                                                 LEP65760
          BX4       X4*X5                                               LEP65770
          BX6       X6+X7                                               LEP65780
          SA6       A4                                                  LEP65790
BSRMAC    SKIPB     FET,,0,R       BACKSKIP RECORDS                     LEP65800
          EQ        TAPOS6                                              LEP65810
TAPOS5    SA4       FSRMAC+1                                            LEP65820
          LX7       18D                                                 LEP65830
          BX4       X4*X5                                               LEP65840
          BX6       X4+X7                                               LEP65850
          SA6       A4                                                  LEP65860
FSRMAC    SKIPF     FET,,0,R       FORWARD SKIP RECORDS                 LEP65870
*                                                                       LEP65880
TAPOS6    BX6       X3                                                  LEP65890
          SA6       A2             SET CDLOC = NEWLOC                   LEP65900
          EQ        IOMPOT         RETURN TO CALLING PROGRAM            LEP65910
*                                                                       LEP65920
IOMREW    SPACE     2                                                   LEP65930
***       IOMREW  (LFN)                                                 LEP65940
*                                                                       LEP65950
*         ENTRY POINT TO REWIND A FILE                                  LEP65960
*                                                                       LEP65970
*         FORTRAN REFERENCE -                                           LEP65980
*                                                                       LEP65990
*         CALL   IOMREW  (LFN)                                          LEP66000
*                                                                       LEP66010
*         WHERE                                                         LEP66020
*                                                                       LEP66030
*         LFN       LOGICAL FILENAME                                    LEP66040
*                                                                       LEP66050
          ENTRY     IOMREW                                              LEP66060
IOMREW    BSSZ      1              ENTRY/EXIT POINT                     LEP66070
          MX3       0                                                   LEP66080
          SX2       0104B                                               LEP66090
          MX4       0                                                   LEP66100
          SX5       B0                                                  LEP66110
          MX6       0                                                   LEP66120
          RJ        =XFETSET$      ESTABLISH FET                        LEP66130
          REWIND    FET,R          REWIND MACRO                         LEP66140
          RJ        FETRET$        GET RET/AT CODES                     LEP66150
          EQ        IOMREW         RETURN TO CALLING PROGRAM            LEP66160
SKPSYST   IFEQ      OS,SCOPE                                            LEP66170
***       BSKIPR/BSKIPF/FSKIPR/FSKIPF (LFN, N)                          LEP66180
*                                                                       LEP66190
*         ENTRY POINTS TO SKIP RECORDS OR FILES                         LEP66200
*                                                                       LEP66210
*         FORTRAN REFERENCES -                                          LEP66220
*                                                                       LEP66230
*         -----------------------                                       LEP66240
*         CALL   BSKIPR  (LFN, N)                                       LEP66250
*         CALL   BSKIPF  (LFN, N)                                       LEP66260
*         CALL   FSKIPR  (LFN, N)                                       LEP66270
*         CALL   FSKIPF  (LFN, N)                                       LEP66280
*         -----------------------                                       LEP66290
*                                                                       LEP66300
*         WHERE                                                         LEP66310
*                                                                       LEP66320
*         LFN       LOGICAL FILE NAME                                   LEP66330
*                                                                       LEP66340
*         N         NO. OF RECORDS OR FILES TO BE SKIPPED               LEP66350
*                   (MAX. 77776B)                                       LEP66360
*                                                                       LEP66370
*                                                                       LEP66380
          ENTRY     BSKIPR,BSKIPF,FSKIPR,FSKIPF                         LEP66390
BSKIPF    BSSZ      1                                                   LEP66400
          SA4       BSKIPF         FETCH RETURN INSTRUCTION             LEP66410
          SB4       17B            LEVEL=17B (FILE)                     LEP66420
          SB5       1              B5=1 FOR BACKWARD SKIP               LEP66430
          EQ        SKIP1                                               LEP66440
BSKIPR    BSSZ      1              ENTRY POINT                          LEP66450
          SA4       BSKIPR         FETCH RETURN INSTRUCTION             LEP66460
          SB4       B0             LEVEL=0  (RECORD)                    LEP66470
          SB5       1              B5=1 FOR BACKWARD SKIP               LEP66480
          EQ        SKIP1                                               LEP66490
FSKIPF    BSSZ      1              ENTRY POINT                          LEP66500
          SA4       FSKIPF         FETCH RETURN INSTRUCTION             LEP66510
          SB4       17B            LEVEL=17B (FILE)                     LEP66520
          SB5       B0             B5=0 FOR FORWARD SKIP                LEP66530
          EQ        SKIP1                                               LEP66540
FSKIPR    BSSZ      1              ENTRY POINT                          LEP66550
          SA4       FSKIPR         FETCH RETURN INSTRUCTION             LEP66560
          SB4       B0             LEVEL=0  (RECORD)                    LEP66570
          SB5       B0             B5=0 FOR FORWARD SKIP                LEP66580
SKIP1     BSS       0                                                   LEP66590
          BX6       X4             (X6) = RETURN INST                   LEP66600
          SA6       SKPRET         STORE RETURN INSTRUCTION             LEP66610
          MX3       0                                                   LEP66620
          SX2       0104B                                               LEP66630
          MX4       0                                                   LEP66640
          SX5       B0                                                  LEP66650
          MX6       0                                                   LEP66660
          RJ        =XFETSET$      ESTABLISH FET                        LEP66670
          SA2       A1+B7          ADDRESS(N) TO X2                (FTN)LEP66680
          SA2       X2             (X2) = N                        (FTN)LEP66690
          SA3       SKPTAB+B5      FETCH CPC ARGUMENT WORD              LEP66700
          MX0       42D                                                 LEP66710
          SX5       B4             (X5) = RECORD LEVEL                  LEP66720
          BX2      -X0*X2          LIMIT N TO 6 OCTAL DIGITS            LEP66730
          LX5       14D            ROTATE LEVEL FOR INSERTION           LEP66740
          LX2       18D            ROTATE N                             LEP66750
          BX6       X3+X5          INSERT LEVEL                         LEP66760
          BX6       X6+X2          INSERT N                             LEP66770
          SA6       SKPMAC+1       STORE AFTER CPC REFERENCE            LEP66780
SKPMAC    SA1       FET                                                 LEP66790
          RJ        =XCPC          ISSUE REQUEST                        LEP66800
          BSSZ      1                                                   LEP66810
          RJ        FETRET$        GET CODE/STATUS                      LEP66820
SKPRET    BSSZ      1              RETURN TO CALLING PROGRAM            LEP66830
          USE       1                                                   LEP66840
SKPTAB    BSS       0                                                   LEP66850
          VFD       18D/3,2/1,40D/240B    FSKIP REQUEST WORD            LEP66860
          VFD       18D/3,2/1,40D/640B    BSKIP REQUEST WORD            LEP66870
          USE       0                                                   LEP66880
SKPSYST   ENDIF                                                         LEP66890
FAMESG    SPACE     2                                                   LEP66900
**        UTILITY BLOCK TO PRINT INFORMATIVE MESSAGE                    LEP66910
*                                                                       LEP66920
          EXT       IOMESSG,LFNBF$,NCOCTL$                              LEP66930
FAMESG    BSS       1                                                   LEP66940
          SA3       =6H0+++                                             LEP66950
          SA1       FET             (X1) = LFN                          LEP66960
          BX7       X2                                                  LEP66970
          SA7       ASTMSG+1       PUT OP ID IN ASTMSG(2)               LEP66980
          BX6       X3                                                  LEP66990
          SA6       ASTMSG         INITIALIZE ASTMSG(1)                 LEP67000
          RJ        =XLFNBF$       BLANKFILL LFN IN (X6)                LEP67010
          SA6       A7+B7          STORE LFN IN ASTMSG(3)               LEP67020
          RJ        =XIOMESSG      PRINT MESSAGE                        LEP67030
          SB1       1              RESTORE (B1) = 1                     LEP67040
          EQ        FAMESG                                              LEP67050
*                                                                       LEP67060
**        UTILITY CODE BLOCK FOR TERMINATION ACTIVITIES                 LEP67070
*                                                                       LEP67080
*         ENTRY -   (X5) = RETURN INSTRUCTION                           LEP67090
*                                                                       LEP67100
FAEXIT    BSS       0                                                   LEP67110
          BX7       X5                                                  LEP67120
          SA7       FARETRN        STORE RETURN INST                    LEP67130
          RJ        =XFETRET$      GET RETURN PARAMETERS FROM FET       LEP67140
          ZR        X1,FARETRN     EXIT IF STATUS = 0                   LEP67150
          RJ        =XNCOCTL$      ENCODE STATUS IN (X6)                LEP67160
          SA5       =10HFAC STATUS                                      LEP67170
          SA6       ASTMSG+2       PLACE STATUS IN ASTMSG(3)            LEP67180
          BX7       X5                                                  LEP67190
          SA7       A6-B7          EXPLANATORY TEXT TO ASTMSG(2)        LEP67200
          RJ        =XIOMESSG      PRINT STATUS MESSAGE                 LEP67210
FARETRN   PS                       RETURN TO CALLING PROGRAM            LEP67220
*                                                                       LEP67230
          END                                                           LEP67240
*DECK       IOMFIP                                                      LEP67250
* =DECK      IOMFIP      IOMFIP      ASSEMBLY                           LEP67260
          IDENT     IOMFIP                                              LEP67270
          TITLE     FILE INFORMATION/IDENTIFICATION PROCEDURES          LEP67280
ASMCTL    SPACE     3                                                   LEP67290
*CALL       IOMACTL                                                     LEP67300
          IFEQ      OS,NOS         *                                    LEP67310
************************************                               (NOS)LEP67320
*    EXTERNAL TEXT COMMON DECKS    *                               (NOS)LEP67330
************************************                               (NOS)LEP67340
          ENDIF                    *                                    LEP67350
************************************                                    LEP67360
COMMON    SPACE     2                                                   LEP67370
***       COMMON BLOCK DECLARATION                                      LEP67380
*                                                                       LEP67390
* =PROCEDURE CDMASTA                                                    LEP67400
*CALL        CDMASTA                                                    LEP67410
*                                                                       LEP67420
          USE       /CDMPAD/                                            LEP67430
CMSIZ     BSS       1                                                   LEP67440
BCSIZ     BSS       1                                                   LEP67450
REQFL     BSS       1                                                   LEP67460
LWAREC    BSS       1                                                   LEP67470
BUFFER    BSS       0                                                   LEP67480
PAD       BSS       300B                                                LEP67490
*                                                                       LEP67500
          USE       0                                                   LEP67510
          SPACE     3                                                   LEP67520
************************************************************************LEP67530
*                                                                      *LEP67540
*         FILE INFORMATION FUNCTIONS INCLUDE FILENAME MANIPULATION     *LEP67550
*         AND FILE/DEVICE STATUS ACQUISITION.                          *LEP67560
*                                                                      *LEP67570
*         PROGRAMMED BY C.A. FELIPPA, OCT 1975  (HALLOWEEN DAY)        *LEP67580
*         UPDATE -  OCT 1977 (HALLOWEEN DAY)                           *LEP67590
*                                                                      *LEP67600
************************************************************************LEP67610
*                                                                      *LEP67620
*         A SUMMARY LIST OF PROCEDURES FOLLOWS.                        *LEP67630
*                                                                      *LEP67640
*         FETSET$   SETS UP A FILE ENVIRONMENT TABLE (FET)             *LEP67650
*                                                                      *LEP67660
*         FETRET$   EXTRACTS RETURNS PARAMETERS FROM CURRENT FET.      *LEP67670
*                                                                      *LEP67680
*         IOMLDIX   EXTRACTS INFORMATION PERTAINING TO A LOGICAL       *LEP67690
*                   DEVICE INDEX IN FORMAT SUITABLE FOR DISPLAY.       *LEP67700
*                                                                      *LEP67710
*         IOMLFN    QUERIES STATUS OF FILENAME IN RELATION TO JOB      *LEP67720
*                                                                      *LEP67730
*         IOMQFC    BREAKS UNIVAC-TYPE DEVICE NAME INTO QUALIFIER      *LEP67740
*                   (=OWNER'S ID), FILENAME, AND FILE CYCLE            *LEP67750
*                                                                      *LEP67760
*         LFNBF     (ALT COMPASS ENTRY LFNBF$) BLANKFILLS A LFN        *LEP67770
*                                                                      *LEP67780
*         LFNZF     (ALT COMPASS ENTRY LFNZF$) ZERO FILLS A LFN        *LEP67790
*                                                                      *LEP67800
*         LJRJN    LEFTJUSTIFY A RIGHT-JUSTIFIED NAME                   LEP67810
*                                                                      *LEP67820
*         LMXXXX    WHERE XXXX =  EQPC,DLOC,NEXT,SECT,UNIT   ARE       *LEP67830
*                   FUNCTIONS TO GET AST INFORMATION FOR A GIVEN LDI.  *LEP67840
*                                                                      *LEP67850
*         RFNBF     (ALT COMPASS ENTRY RJNBF$) BLANKFILLS A             LEP67860
*                   ZEROFILLED RIGHT-JUSTIFIED NAME STRING              LEP67870
*                                                                      *LEP67880
*         NCOCTL$   COMPASS-CALLABLE PROCEDURE FOR CONVERTING AN       *LEP67890
*                   1-9 DIGIT INTEGER TO OCTAL DISPLAY CODE            *LEP67900
*                                                                      *LEP67910
************************************************************************LEP67920
FETSET$   SPACE     2                                                   LEP67930
***       FETSET$                                                       LEP67940
*                                                                       LEP67950
FETSET$   SPACE     2                                                   LEP67960
*                                                                       LEP67970
*         COMPASS-CALLABLE PROCEDURE FOR SETTING UP                     LEP67980
*         A FILE ENVIRONMENT TABLE (FET)                                LEP67990
*                                                                       LEP68000
*         COMPASS REFERENCE -                                           LEP68010
*                                                                       LEP68020
*         RJ        FETSET$                                             LEP68030
*                                                                       LEP68040
*         ENTRY REGISTER SET -                                          LEP68050
*         (X1)      ADDRESS(42/LFN,18/FNT-POINTER)                      LEP68060
*                   (LAST FIELD OPTIONAL)                               LEP68070
*         (X2)      48/0,3/R,3/EP,3/XP,3/FETL,    WHERE                 LEP68080
*                   R = RANDOM ACCESS BIT, EP = ERROR PROCESSING BIT,   LEP68090
*                   XP = EXTENDED ERROR PROC BIT, FETL = SIZE(FET)-5    LEP68100
*         (X3)      ADDRESS(BUFFER)                                     LEP68110
*         (X4)      N = SIZE OF BLOCK TO BE XMITTED                     LEP68120
*         (X5)      0  IF READ CONDITION,   N  IF WRITE                 LEP68130
*         (X6)      LIMIT-ADDRESS(BUFFER)-N                             LEP68140
*                                                                       LEP68150
*         EXIT REGISTER CONFIGURATION -                                 LEP68160
*         (B1)=1, (B7)=1, (B6)=2                                        LEP68170
*         B2,B3,B4,B5,A0,A1,A2,A3,X1,X3        PRESERVED                LEP68180
*         A4,A5,A6,A7,X0,X2,X4,X5,X6,X7        DESTROYED                LEP68190
*         ENTRY VALUES OF (X4) AND (X5) PLACED IN NWXF AND NWXWRT       LEP68200
*         (BLOCK /CDMAST/), RESPECTIVELY.                               LEP68210
*                                                                       LEP68220
*                                                                       LEP68230
*         EXIT FET CONFIGURATION (SCOPE) -                              LEP68240
*                                                                       LEP68250
*  WORD / BIT      5         4         3         2         1            LEP68260
*         987654321098765432109876543210987654321098765432109876543210  LEP68270
*  FET+0  ----------LOGICAL-FILENAME----------------................11  LEP68280
*  FET+1  ............R..E...X..................FETL-------FIRST------  LEP68290
*  FET+2  ..........................................--------IN--------  LEP68300
*  FET+3  ..........................................--------OUT-------  LEP68310
*  FET+4  -FNTPOINTER-..............................-------LIMIT------  LEP68320
*  FET+5  ............................................................  LEP68330
*  FET+6  ............-(FETEXT-POINTER)-..............................  LEP68340
*  FET+7  ............................................................  LEP68350
*  FET+8  ............-EOI-XFER-ADDRESS-...........---ERROR-ADDRESS---  LEP68360
*                                                                       LEP68370
*         WHERE -                                                       LEP68380
*         .         ZERO BIT                                            LEP68390
*         FIRST     ADDRESS(BUFFER)                                     LEP68400
*         IN        ADDRESS(BUFFER)     ON READ-TYPE CONDITION          LEP68410
*                   ADDRESS(BUFFER)+N   ON WRITE-TYPE CONDITION         LEP68420
*         OUT       ADDRESS(BUFFER)                                     LEP68430
*         LIMIT     ADDRESS(BUFFER)+N+(X6)                              LEP68440
*         FETEXT POINTER      ONLY SET IF XP-BIT = 1                    LEP68450
*                                                                       LEP68460
*         FOR NOS, WORDS FET+6 AND FET+8 ARE ZERO, AND THE XP BIT       LEP68470
*         (WORD FET+1) HAS NO EFFECT.                                   LEP68480
*                                                                       LEP68490
          ENTRY     FETSET$                                             LEP68500
FETSET$   BSSZ      1              ENTRY/EXIT                           LEP68510
          SB7       1              (B7) = 1                             LEP68520
          BX7       X4             (X7) = N                             LEP68530
          IX4       X3+X4          (X4) = ADDRESS(BUFFER)+N             LEP68540
          SB6       B7+B7          (B6) = 2                             LEP68550
          NZ        X6,*+1                                              LEP68560
          SX6       B7             IF (X6) = 0, SET (X6) = 1            LEP68570
+         SA7       NWXF           SAVE N IN NWXF                       LEP68580
          BX7       X5                                                  LEP68590
          IX6       X4+X6          (X6) = LIMIT                         LEP68600
          SA7       A7+B7          SAVE ENTRY (X5) IN NWXWRT            LEP68610
          MX7       0              (X7) = 0                             LEP68620
          SA6       FET+4          SAVE LIMIT IN FET+4 = FET(5)         LEP68630
          IFEQ      OS,SCOPE                                            LEP68640
          SX6       CPCERR         FETCH ERROR-XFER ADS          (SCOPE)LEP68650
          BX0       X6             (X0) = ERROR XFER ADS         (SCOPE)LEP68660
          LX0       30                                           (SCOPE)LEP68670
          BX6       X0+X6          COMPLETE ASSEMBLY OF FET(9)   (SCOPE)LEP68680
          ELSE                                                          LEP68690
          MX6       0              (X6) = 0                        (NOS)LEP68700
          ENDIF                                                         LEP68710
          SA7       RETCOD         CLEAR RETCOD                         LEP68720
          SB1       X1             SAVE (X1) IN B1                      LEP68730
          SA7       A7+B7          CLEAR EOFCOD                         LEP68740
          SA6       FET+8          STORE FET(9)                         LEP68750
          SA7       A7+B7          CLEAR STATUS                         LEP68760
          SA7       A7+B7          CLEAR TAPERR/DTLERR                  LEP68770
          SA7       A7+B7          CLEAR RSKCNT                         LEP68780
          BX6       X3             (X6) = OUT = ADDRESS(BUFFER)         LEP68790
          SA7       A7+B7          CLEAR NWRDXF                         LEP68800
          SA7       A6-B7          CLEAR FET(8)                         LEP68810
          MX0       42D            (X0) = LFN MASK                      LEP68820
          SA7       A7-B7          CLEAR FET(7)                         LEP68830
          SA7       A7-B7          CLEAR FET(6)                         LEP68840
          IX7       X3+X5          (X7) = IN =  ADDRESS(BUFFER)+(X5)    LEP68850
          SA6       A7-B6          FET(4) = OUT                         LEP68860
          SA5       X1             (X5) = LFN/FNTPNT                    LEP68870
          SA7       A6-B7          FET(3) = IN                          LEP68880
          SX1       B6+B7          (X1) = 3                             LEP68890
          BX6       X0*X5          (X6) = ISOLATED LFN                  LEP68900
          BX5       -X0*X5         (X5) = ISOLATED FNTPNT               LEP68910
          SA4       A7+B6          (X4) = LIMIT = FET(5)                LEP68920
          BX6       X6+X1          SET INTERLOCK AND XMISSION MODE BITS LEP68930
          MX0       -3             (X0) = OCTAL DIGIT MASK              LEP68940
          SA6       A7-B6          STORE FET-HEADER IN FET(1)           LEP68950
          LX5       48D            (X5) = LEFTJUSTIFIED FNTPNT          LEP68960
          BX1       -X0*X2         (X1) = FETL                          LEP68970
          BX7       X5+X4          (X7) = MERGED FNTPNT/LIMIT FIELDS    LEP68980
          AX2       3              RIGHTJUSTIFY R/E/X BITS FIELD        LEP68990
          SA7       A4             STORE FET(5)                         LEP69000
          BX4       -X0*X2         (X4) = XP BIT                        LEP69010
          BX2       X0*X2          CLEAR XP-BIT FIELD                   LEP69020
          LX2       1              SHIFT R/E BITS TO PROPER DISTANCE    LEP69030
          BX2       X2+X4          REINSERT XP BIT                      LEP69040
          LX1       18D            ROTATE FETL                          LEP69050
          LX2       40D            POSITION R/E/X FIELDS                LEP69060
          BX1       X1+X3          (X1) = MERGED FETL/FIRST FIELDS      LEP69070
          BX6       X1+X2          (X6) = MERGED R/E/X/FETL/FIRST FIELDSLEP69080
          SA6       A6+B7          STORE FET(2)                         LEP69090
          SX1       B1             RESTORE (X1)                         LEP69100
          SB1       B7             (B1) = 1  FOR NOS                    LEP69110
          IFEQ      OS,SCOPE                                            LEP69120
          ZR        X4,FETSET$     EXIT IF XP=0                         LEP69130
          SX7       FETEXT         (X7) = ADDRESS OF FET EXTENSION      LEP69140
          SX6       B7             (X6) = 1                             LEP69150
          SA6       X7             FETX(1) = 1                          LEP69160
          LX7       30D            ROTATE ADDRESS TO BITS 30-47         LEP69170
          SA7       A7+B6          STORE FETX-PNT IN FET(7)             LEP69180
          ENDIF                                                         LEP69190
          EQ        FETSET$        RETURN TO PROCEDURE CALLER           LEP69200
*                                                                       LEP69210
***       FETSET  (LFN, X2, BUFFER, N, NWRT)                            LEP69220
*                                                                       LEP69230
*                                                                       LEP69240
*         FORTRAN-CALLABLE FORM OF FETSET$.  USED PRIMARILY             LEP69250
*         FOR DEBUGGING PURPOSES                                        LEP69260
*                                                                       LEP69270
*         FORTRAN REFERENCE                                             LEP69280
*                                                                       LEP69290
*         CALL      FETSET  (LFN, X2, A, N, NWRT)                       LEP69300
*                                                                       LEP69310
          ENTRY     FETSET                                              LEP69320
FETSET    BSSZ      1                                                   LEP69330
          SB7       1                                              (FTN)LEP69340
          SA2       A1+B7                                          (FTN)LEP69350
          SA3       A2+B7                                          (FTN)LEP69360
          SA2       X2                                             (FTN)LEP69370
          SA4       A3+B7                                          (FTN)LEP69380
          SA5       A4+B7                                          (FTN)LEP69390
          SA4       X4                                             (FTN)LEP69400
          SA5       X5                                             (FTN)LEP69410
          SX6       B7                                                  LEP69420
          RJ        FETSET$                                             LEP69430
          EQ        FETSET         RETURN TO FORTRAN PROGRAM            LEP69440
*                                                                       LEP69450
FETRET$   SPACE     2                                                   LEP69460
***       FETRET$                                                       LEP69470
*                                                                       LEP69480
*         COMPASS-CALLABLE PROCEDURE TO EXTRACT STATUS PARAMETER        LEP69490
*         FIELDS FROM THE F.E.T. AND PUT'EM IN SINGLE WORDS             LEP69500
*                                                                       LEP69510
*         COMPASS REFERENCE -                                           LEP69520
*                                                                       LEP69530
*         RJ        FETRET$                                             LEP69540
*                                                                       LEP69550
*         EXIT VALUES -                                                 LEP69560
*                                                                       LEP69570
*         (B7)=1, (B6)=2, (X1)=STATUS                                   LEP69580
*         RETCOD,EOICOD,STATUS,DTLERR      STORED IN /CDMAST/           LEP69590
*         NWRDXF    UPDATED BY  OUT-IN+NWXWRT                           LEP69600
*                                                                       LEP69610
*         REGISTER UTILIZATION -                                        LEP69620
*         B1,B2,B3,B4,B5,A0,A4,A5,X0,X4,X5    PRESERVED                 LEP69630
*         A1,A2,A3,A6,A7,X1,X2,X3,X6,X7       DESTROYED                 LEP69640
*                                                                       LEP69650
          ENTRY     FETRET$                                             LEP69660
FETRET$   BSSZ      1              ENTRY/EXIT                           LEP69670
          SB7       1                                                   LEP69680
          SA1       FET+0          (X1) = FET HEADER                    LEP69690
          SB6       B7+B7          (B6) = 2                             LEP69700
          MX6       -9D            (X6) = RETURN CODE MASK              LEP69710
          SA2       A1+B6          (X2) = IN = FET+2                    LEP69720
          BX6       -X6*X1         (X6) = RETCOD                        LEP69730
          SA3       A2+B7          (X3) = OUT = FET+3                   LEP69740
          SA6       RETCOD         STORE RETURN CODE                    LEP69750
          AX1       9              RIGHTJUSTIFY EOI INDICATOR           LEP69760
          MX6       -1                                                  LEP69770
          IX7       X3-X2          (X7) = OUT-IN                        LEP69780
          SA2       NWXWRT         (X2) = NWXF ON WRITE OP, ELSE 0      LEP69790
          SA3       NWRDXF         (X3) = CURRENT NWRDXF                LEP69800
          SA7       OUTMIN         PLACE (OUT-IN) IN OUTMIN             LEP69810
          BX6       -X6*X1         (X6) = EOICOD                        LEP69820
          IX7       X2-X7          (X7) = IN-OUT+NWXWRT                 LEP69830
          SA6       A6+B7          STORE EOICOD                         LEP69840
          IX7       X7+X3                                               LEP69850
          SA7       A3             STORE UPDATED NWRDXF                 LEP69860
          IFEQ      OS,SCOPE                                            LEP69870
          SA1       A6+B7          FETCH STATUS WORD             (SCOPE)LEP69880
          ELSE                                                          LEP69890
          AX1       1              RIGHTJUSTIFY ABT CODE           (NOS)LEP69900
          MX6       -4                                             (NOS)LEP69910
          BX6       -X6*X1         (X6) = ABT CODE                 (NOS)LEP69920
          LX1       X6                                             (NOS)LEP69930
          SA6       A6+B7          STORE IN STATUS                 (NOS)LEP69940
          ZR        X6,FETRET$                                     (NOS)LEP69950
          SA1       FET+6                                          (NOS)LEP69960
          SX2       X6-11B                                         (NOS)LEP69970
          MX3       -12D                                           (NOS)LEP69980
          BX6       -X3*X1                                         (NOS)LEP69990
          NZ        X2,FETRET$                                     (NOS)LEP70000
          SA6       A6+B7          STORE DETAILED ERROR CODE       (NOS)LEP70010
          ENDIF                                                         LEP70020
          EQ        FETRET$        RETURN                               LEP70030
CPCERR    SPACE     2                                                   LEP70040
***       CPCERR                                                        LEP70050
*                                                                       LEP70060
*         OWNCODE ERROR PROCESSING PROCEDURE.  NOTE THAT THIS           LEP70070
*         CODE BLOCK USES ONLY REGISTERS A1,X1,A6,X6,X0.   THIS         LEP70080
*         IS IMPORTANT, FOR CPC USES ONLY THE 1ST FOUR.                 LEP70090
*                                                                       LEP70100
          IFEQ      OS,SCOPE                                            LEP70110
CPCERR    BSSZ      1                                            (SCOPE)LEP70120
          BX6       X1                                           (SCOPE)LEP70130
          AX1       9D             RIGHTJUSTIFY STATUS FIELD     (SCOPE)LEP70140
          SA6       FET            FIX TO GODDAMN SCOPE, 5/79    (SCOPE)LEP70150
          MX0       -5             MASK FOR STATUS FIELD         (SCOPE)LEP70160
          BX6       -X0*X1         (X6) = STATUS                 (SCOPE)LEP70170
          SA1       FET+6          (X1) = FET(7)                 (SCOPE)LEP70180
          SA6       STATUS         STORE STATUS WORD             (SCOPE)LEP70190
          AX1       30D            RIGHTJUSTIFY FETX-PNT FIELD   (SCOPE)LEP70200
          ZR        X1,CPCERR      RETURN IF XP=0                (SCOPE)LEP70210
          SA1       X1             (X1) = FET EXTENSION WORD     (SCOPE)LEP70220
          BX6       X1             SAVE (X1) IN (X6)             (SCOPE)LEP70230
          AX6       18D            RIGHTJUSTIFY DETAILED ERROR   (SCOPE)LEP70240
          BX6       -X0*X6         (X6) = TAPERR                 (SCOPE)LEP70250
          AX1       24D            RIGHTJUSTIFY RES SKIP COUNT   (SCOPE)LEP70260
          MX0       -16D                                         (SCOPE)LEP70270
          SA6       A6+B7          STORE TAPERR                  (SCOPE)LEP70280
          BX6       -X0*X1         (X6) = RSKCNT                 (SCOPE)LEP70290
          SA6       A6+B7          STORE RSKCNT                  (SCOPE)LEP70300
          EQ        CPCERR         TO CPC EXIT WORD              (SCOPE)LEP70310
          ENDIF                                                         LEP70320
IOMLDIX   SPACE     2                                                   LEP70330
***       IOMLDIX                                                       LEP70340
*                                                                       LEP70350
*         EXTRACT INFORMATION PERTAINING TO A LOGICAL DEVICE INDEX      LEP70360
*         (LDIX) AND PLACE IT IN FORMAT SUITABLE FOR TABLE PRINT        LEP70370
*         BY SUBROUTINE IOMTAB.                                         LEP70380
*         ALL INPUT/OUTPUT IS DONE THROUGH BLOCK /CDMPAD/.              LEP70390
*                                                                       LEP70400
          ENTRY     IOMLDIX                                             LEP70410
IOMLDIX   BSSZ      1                                                   LEP70420
          SA1       LDIX           (X1) = LDI INDEX                     LEP70430
          SB7       1              (B7) = 1                             LEP70440
          SB2       MAXLDI         (B2) = MAXLDI = AST ROW DIMENSION    LEP70450
          SB1       X1             (B1) = LDI                           LEP70460
          SB6       B7+B7          (B6) = 2                             LEP70470
          SA3       B1+ASTYPE-1    (X3) = ASTYPE(LDI)                   LEP70480
          SB3       B2+B2          (B3) = 2*MAXLDI                      LEP70490
          SA2       A3-B2          (X2) = ASTOPT(LDI)                   LEP70500
          SA5       A3+B3          (X5) = ASTLOC(LDI) = CDLOC           LEP70510
          SX7       X3-4           (X7) = ASTYPE(LDI)-4 = TYPEX         LEP70520
          BX6       X2             (X6) = OPTX                          LEP70530
          SA7       TYPEX          STORE TYPEX                          LEP70540
          SA1       ASTSEC+4+X7    (X1) = ASTSEC(TYPEX+4) = SECTOR      LEP70550
          SA6       A7+B7          STORE OPTX                           LEP70560
          BX6       X5             (X6) = CDLOC                         LEP70570
          SA2       A5+B2          (X2) = ASTNXT(LDI)                   LEP70580
          SA6       A6+B6          STORE CDLOC                          LEP70590
          BX7       X1             (X7) = SECTOR                        LEP70600
          SA1       =10H           (X1) = BLANK WORD                    LEP70610
          SB4       X7             SAVE SECTOR IN (B4)                  LEP70620
          SA3       A2+B2          (X3) = ASTLIM(LDI)                   LEP70630
          SA7       A7+B6          STORE SECTOR                         LEP70640
          SA4       A3+B2          (X4) = ASTWXR(LDI)                   LEP70650
          BX6       X2             (X6) = NEXT                          LEP70660
          SA5       A4+B2          (X5) = ASTWXW(LDI)                   LEP70670
          BX7       X3             (X7) = LIMIT                         LEP70680
          SA6       A6+B7          STORE NEXT                           LEP70690
          BX6       X1             (X6) = BLANK                         LEP70700
          SA7       A6+B7          STORE LIMIT                          LEP70710
          SA6       A6+B6          STORE TRANSPARENT FULL DEV MARK      LEP70720
          LX7       X4             (X7) = KWXRED                        LEP70730
          BX6       X5             (X6) = KWXWRT                        LEP70740
          SA4       ASTCNT         (X4) = KACTVD (ACTIVE DEVICE COUNTER)LEP70750
          SA7       A7+B6          STORE KWXRED                         LEP70760
          SA6       A6+B6          STORE KWXWRT                         LEP70770
          SX6       X4+B7                                               LEP70780
          BX0       X1             SAVE BLANK WORD IN (X0)              LEP70790
          SA6       A4             STORE INCREMENTED KACTVD             LEP70800
          SA5       A4+B7          (X5) = KFULLD (FULL   DEVICE COUNTER)LEP70810
          PL        X3,IOMLDI1     TEST FOR FULL DEVICE (NEG LIMIT)     LEP70820
          SX7       1R*                                                 LEP70830
          LX7       54D                                                 LEP70840
          SX6       X5+B7          INCREMENT KFULLD BY 1                LEP70850
          SA7       A7-B7          STORE FULL DEVICE MARK               LEP70860
          SA6       A5             STORE UPDATED KFULLD                 LEP70870
IOMLDI1   BSS       0                                                   LEP70880
          SA1       TABFMT14       (X1) = TABFMT(1)                     LEP70890
          BX5       X0             (X5) = TABFMT(5) (DIR. ACCESS DEVICE)LEP70900
          SA2       A1+B7          (X2) = TABFMT(2)                     LEP70910
          SA3       A1+B6          (X3) = TABFMT(3)                     LEP70920
          BX6       X1                                                  LEP70930
          SA6       TABFMT+0       STORE TABFMT(1)                      LEP70940
          BX7       X2                                                  LEP70950
          SA4       A3+B7          (X4) = TABFMT(4) (DIR. ACCESS DEVICE)LEP70960
          BX6       X3                                                  LEP70970
          SA7       A6+B7          STORE TABFMT(2)                      LEP70980
          SA1       A4+B7          (X1) = TABFMT(6)                     LEP70990
          SA2       A4+B6          (X2) = TABFMT(7)                     LEP71000
          SA6       A6+B6          STORE TABFMT(3)                      LEP71010
          BX7       X0             (X7) = BLANK                         LEP71020
          GT        B4,IOMLDI2     BRANCH AS PER SECTOR VALUE           LEP71030
          SA4       A2+B7          (X4) = TABFMT(4)  (TAPE DEVICE)      LEP71040
          SA5       A2+B6                                               LEP71050
          SA7       LIMIT          BLANK OUT LIMIT  WORD                LEP71060
          SA7       SECTOR         BLANK OUT SECTOR WORD                LEP71070
IOMLDI2   BSS       0                                                   LEP71080
          LX6       X4                                                  LEP71090
          BX7       X5                                                  LEP71100
          SA6       A6+B7          STORE TABFMT(4)                      LEP71110
          BX6       X1                                                  LEP71120
          SA7       A6+B7          STORE TABFMT(5)                      LEP71130
          BX7       X2                                                  LEP71140
          SA1       ASTLFN-1+B1    (X1) = ASTLFN(LDI)                   LEP71150
          SA6       A6+B6          STORE TABFMT(6)                      LEP71160
          SA5       A1-B2          (X5) = PFN = ASTPFN(LDI)             LEP71170
          SA7       A7+B6          STORE TABFMT(7)                      LEP71180
          BX7       X5                                                  LEP71190
          SA7       PFN                                                 LEP71200
          RJ        LFNBF$         BLANKFILL LFN IN (X6)                LEP71210
          SA6       LFNAME         STORE BLANK-PADDED LFN               LEP71220
          ZR        X5,IOMLDIX     EXIT IF PFN=0 (LOCAL FILE)           LEP71230
          BX1       X5             (X1) = PFN                           LEP71240
          RJ        LFNBF$         BLANKFILL PFN IN (X6)                LEP71250
          MX0       -6                                                  LEP71260
          SA6       PFN            STORE BLANK-PADDED PFN               LEP71270
          BX6       -X0*X5         (X6) = PFN CYCLE                     LEP71280
          SA6       A6+B7          STORE PFNCY                          LEP71290
          SA1       A5-B2          (X1) = PFNID = ASTQFR(LDI)           LEP71300
          RJ        RFNBF$         BLANKFILL PFNID IN (X6)              LEP71310
          SA6       PFNID          STORE BLANK-PADDED PFNID             LEP71320
          EQ        IOMLDIX        RETURN TO CALLING PROGRAM            LEP71330
TABFMT14  DIS       4,(2H +I3,  2XA7,2XO4, 2I4,     I4,3I7,             LEP71340
TABFMT67  DIS       2,A1,2I8,2H +)                                      LEP71350
TABFMT45  DIS       2,A4,1XO6,1XO6,A7,               (TAPE DEVICE)      LEP71360
LDIX      EQU       PAD+64                                              LEP71370
LFNAME    EQU       PAD+65                                              LEP71380
EQCODE    EQU       PAD+66                                              LEP71390
TYPEX     EQU       PAD+67                                              LEP71400
OPTX      EQU       PAD+68                                              LEP71410
SECTOR    EQU       PAD+69                                              LEP71420
CDLOC     EQU       PAD+70                                              LEP71430
NEXT      EQU       PAD+71                                              LEP71440
LIMIT     EQU       PAD+72                                              LEP71450
MARK      EQU       PAD+73                                              LEP71460
KWXRED    EQU       PAD+74                                              LEP71470
KWXWRT    EQU       PAD+75                                              LEP71480
PFN       EQU       PAD+76                                              LEP71490
PFNCY     EQU       PAD+77                                              LEP71500
PFNID     EQU       PAD+78                                              LEP71510
TABFMT    EQU       PAD+80                                              LEP71520
*                                                                       LEP71530
IOMLFN    SPACE     2                                                   LEP71540
***       IOMLFN    (LFN)                                               LEP71550
*                                                                       LEP71560
*         FUNCTION TO QUERY STATUS OF LOGICAL FILE NAME IN              LEP71570
*         RELATION TO JOB                                               LEP71580
*                                                                       LEP71590
*         FORTRAN REFERENCE -                                           LEP71600
*                                                                       LEP71610
*         LFNST =   IOMLFN  (LFN)                                       LEP71620
*                                                                       LEP71630
*         WHERE                                                         LEP71640
*                                                                       LEP71650
*         LFN       LOGICAL FILENAME                                    LEP71660
*                                                                       LEP71670
*         IOMLFN    ZERO,  LFN IS NOT ASSIGNED TO JOB                   LEP71680
*                   NEGATIVE,  LFN IS A LOCAL FILE                      LEP71690
*                   POSITIVE, LFN IS ATTACHED PERM FILE                 LEP71700
*                   BITS 0-4 OF IOMLFN CONVEY INFORMATION AS            LEP71710
*                                                                       LEP71720
*                   REGARDS ACCESS PERMISSIONS (SEE SCOPE 3.4 MANUAL)   LEP71730
          ENTRY     IOMLFN                                              LEP71740
IOMLFN    BSS       1              ENTRY/EXIT                           LEP71750
          MX7       0              (X7) = 0                             LEP71760
          SA5       X1             LFN TO (X5)                     (FTN)LEP71770
          SA7       FET+2                                               LEP71780
          SB7       1                                                   LEP71790
          SA7       A7-B7                                               LEP71800
          MX0       42D            GENERATE LFN MASK                    LEP71810
          SA6       A7-B7          SET LIST HEADER                      LEP71820
          BX6       X0*X5                                               LEP71830
          SA6       A7             STORE LFN                            LEP71840
          IFEQ      OS,SCOPE                                            LEP71850
          PERM      FET,RC         PERM MACRO                    (SCOPE)LEP71860
          ENDIF                                                         LEP71870
          SA5       FET            (X5) = EXIT WORD                     LEP71880
          MX0       -9D                                                 LEP71890
          AX5       9D             RIGHTJUSTIFY RETURN FIELD            LEP71900
          BX5       -X0*X5         EXTRACT RETURN FIELD                 LEP71910
          SX6       X5             PLACE IN (X6)                        LEP71920
          AX5       4              RIGHTJUSTIFY BIT 13                  LEP71930
          ZR        X5,IOMLFN      EXIT IF PERM OR NONEXISTING FILE     LEP71940
          BX6       -X6            COMPLEMENT (X6) IF LOCAL FILE        LEP71950
          EQ        IOMLFN         RETURN                               LEP71960
*                                                                       LEP71970
IOMQFC    SPACE     2                                                   LEP71980
***       IOMQFC    (EDN, QFC)                                          LEP71990
*                                                                       LEP72000
*         TO BREAK DOWN UNIVAC-TYPE DEVICE NAME TEXTSTRING INTO         LEP72010
*         PRIMITIVE COMPONENTS - QUALIFIER, FILENAME, CYCLE             LEP72020
*                                                                       LEP72030
*         FORTRAN REFERENCE -                                           LEP72040
*                                                                       LEP72050
*         CALL      IOMQFC  (EDN, QFC)                                  LEP72060
*                                                                       LEP72070
*         WHERE                                                         LEP72080
*                                                                       LEP72090
*         EDN       EXTERNAL DEVICE NAME SUPPLIED (AS 2ND ARGUMENT)     LEP72100
*                   TO DMDAST.  ITS GENERAL FORM IS                     LEP72110
*                   QUALIFIER*FILENAME(FCYCLE), 20 CHARS MAX            LEP72120
*                   FIRST/LAST COMPONENTS ARE OPTIONAL                  LEP72130
*                                                                       LEP72140
*         QFC       THREE WORD OUTPUT ARRAY RECEIVING -                 LEP72150
*                   QFC(1)    QUALIFIER (1-7 CHARS) RJ, ZEROFILLED      LEP72160
*                   QFC(2)    FILENAME  (1-7 CHARS) LJ, ZEROFILLED      LEP72170
*                   QFC(3)    DECODED CYCLE NUMBER                      LEP72180
*                   IF ANY COMPONENT IS MISSING, THE CORRESPONDING      LEP72190
*                   ENTRY OF QFC WILL RECEIVE ZERO.                     LEP72200
*                                                                       LEP72210
          ENTRY     IOMQFC                                              LEP72220
GETQFC    BSS       0                                                   LEP72230
IOMQFC    BSSZ      1                                                   LEP72240
          SB7       1              (B7) = 1                             LEP72250
          MX0       6              (X0) = CHAR MASK                     LEP72260
          SA2       A1+B7          (X2) = ADDRESS(QFC)             (FTN)LEP72270
          MX6       0              (X6) = 0                        (FTN)LEP72280
          SA1       X1             (X1) = EDN(1)                   (FTN)LEP72290
          MX7       0              (X7) = 0                        (FTN)LEP72300
          SA2       X2             (A2) POINTS TO QFC(1)           (FTN)LEP72310
          SB6       1R(            (B6) = FCYCLE DELIMITER              LEP72320
          SB5       1R*            (B5) = QUALIFIER DELIMITER           LEP72330
          SA6       A2             QFC(1) = 0                           LEP72340
          SA7       A2+B7          QFC(2) = 0                           LEP72350
          SX5       -2             (X5) = - MAX. WORDS IN EDN           LEP72360
          SB3       60-48          (B3) = 60-48, 48 BEING MAX BITS/QF   LEP72370
          SB4       1R9            (B4) = LARGEST ALPHANUMERIC CHAR     LEP72380
          LX0       6              (X0) = RIGHT JUSTIFIED CHAR MASK     LEP72390
          SA6       A7+B7          QFC(3) = 0                           LEP72400
          SX4       1R0            (X4) = 1R0 FOR FCYCLE DECODE         LEP72410
*                                                                       LEP72420
GETQFC1    BSS       0                                                  LEP72430
           MX6       0             (X6) = 0                             LEP72440
           SB2       60            INITIALIZE (X6)-LJ COUNTER           LEP72450
           MX7       0                                                  LEP72460
GETQFC2    BSS       0                                                  LEP72470
           LX1       6             RIGHTJUSTIFY NEXT CHAR               LEP72480
           BX2       X0*X1         ISOLATE CHAR IN (X2)                 LEP72490
           SB1       X2            PLACE CHAR IN (B1) FOR TESTS         LEP72500
           BX1      -X0*X1         CLEAR VACATED POSITION IN (X1)       LEP72510
           EQ        B1,GETQFC7    GET OFF SCANLOOP ON ZERO BYTE        LEP72520
           GT        B1,B4,GETQFC4 TEST FOR SPECIAL CHAR (CODE GT 1R9)  LEP72530
           LE        B2,B3,GETQFC3 LIMIT (X6)STRING TO 7 CHARACTERS     LEP72540
           LX6       6             FOREPLAY ON (X6)                     LEP72550
           SB2       B2-6          DECREMENT LEFTJUSTIFIER COUNT        LEP72560
           BX6       X2+X6         SIX BITS TO PASSION PIT              LEP72570
           LX7       B2,X6         (X7) = LEFTJUSTIFIED OUTPUT STRING   LEP72580
GETQFC3    BSS       0                                                  LEP72590
           NZ        X1,GETQFC2    TEST FOR SOURCE STRING EXHAUSTION    LEP72600
           SX5       X5+B7         INCREMENT EDN WORD COUNT             LEP72610
           SA1       A1+B7         LOAD NEXT EDN WORD IN (X1)           LEP72620
           NG        X5,GETQFC2    CONTINUE SCAN IF (X5) LT 0           LEP72630
           EQ        GETQFC7       ELSE GET OFF LOOP                    LEP72640
GETQFC4    BSS       0             SPECIAL CHAR TESTS FOLLOW            LEP72650
           NE        B1,B5,GETQFC5 TEST FOR ASTERISK (QUAL DELIMITER)   LEP72660
           SB3       18                                                 LEP72670
           SA6       A2            STORE QUALIFIER IN QFC(1)            LEP72680
           SB5       B0            DEFUSE QUAL DELIMITER TRAP           LEP72690
           NZ        X1,GETQFC1    RESUME SCAN FROM TOP IF (X1)NZ       LEP72700
           EQ        GETQFC6                                            LEP72710
GETQFC5    BSS       0                                                  LEP72720
           NE        B1,B6,GETQFC7 ABANDON SCAN ON ANY SPEC CHAR BUT 1R(LEP72730
           SA7       A7            STORE FILENAME IN QFC(2)             LEP72740
           SB6       B0            TURN OFF CYCLE DELIMITER TRAP        LEP72750
           NZ        X1,GETQFC1    RESUME SCAN FROM TOP IF (X1)NZ       LEP72760
GETQFC6    BSS       0                                                  LEP72770
           SX5       X5+B7         INCREMENT EDN WORD COUNT             LEP72780
           SA1       A1+B7         LOAD NEXT EDN WORD IN (X1)           LEP72790
           NG        X5,GETQFC1    CONTINUE SCAN IF (X5) LT 0           LEP72800
*                                                                       LEP72810
GETQFC7   BSS       0              TERMINATION SECTION FOLLOWS          LEP72820
          EQ        B6,GETQFC8     TEST FOR NAME/CYCLE                  LEP72830
          SA7       A7             STORE FILENAME IN QFC(2)             LEP72840
          EQ        IOMQFC         EXIT                                 LEP72850
GETQFC8   BSS       0              FILE CYCLE DECODING FOLLOWS          LEP72860
          BX7       X0*X6          (X7) = ENCODED LAST FC DIGIT         LEP72870
          AX6       6                                                   LEP72880
          BX6       X0*X6          (X6) = ENCODED FIRST FC DIGIT IF ANY LEP72890
          SB1       X6                                                  LEP72900
          IX7       X7-X4          CONVERT FIRST DIGIT TO NUMERIC       LEP72910
          GT        B1,B4,GETQFC10                                      LEP72920
          IX6       X6-X4          CONVERT FIRST DIGIT TO NUMERIC       LEP72930
          SB1       X6                                                  LEP72940
          LX6       3                                                   LEP72950
          LE        B1,GETQFC10                                         LEP72960
          IX7       X6+X7                                               LEP72970
          SB1       B1+B1                                               LEP72980
          SX7       X7+B1          (X7) = DECODED FILE CYCLE            LEP72990
GETQFC10  BSS       0                                                   LEP73000
          SA7       A7+B7          STORE FILE CYCLE IN QFC(3)           LEP73010
          EQ        IOMQFC         EXIT                                 LEP73020
LFNBF     SPACE     2                                                   LEP73030
***       LFNBF     (LFN)                                               LEP73040
*                                                                       LEP73050
*         FUNCTION PROCEDURE TO BLANKFILL A LOGICAL FILE NAME WORD.     LEP73060
*                                                                       LEP73070
*         FORTRAN REFERENCE&                                            LEP73080
*                                                                       LEP73090
*         LFNB =    LFNBF (LFN)                                         LEP73100
*                                                                       LEP73110
*         WHERE LFN IS WORD HOLDING A ZERO-FILLED LFN STRING            LEP73120
*                                                                       LEP73130
*         COMPASS REFERENCE -                                           LEP73140
*                                                                       LEP73150
*         (X1) =    LFN                                                 LEP73160
*         RJ        LFNBF$                                              LEP73170
*                                                                       LEP73180
*         THE RESULT RETURNS IN THE FUNCTION REGISTER (X6)              LEP73190
*         (B6),(B7) ARE SET TO 2,1 RESPECTIVELY.                        LEP73200
*                                                                       LEP73210
*                                                                       LEP73220
          ENTRY     LFNBF,LFNBF$                                        LEP73230
LFNBF$    BSS       1              COMPASS-CALLABLE ENTRY POINT         LEP73240
          MX6       60D            (X6) = FULL WORD MASK                LEP73250
          SB6       7              (B6) = MAX. CHARS IN LFN             LEP73260
          BX2       X1             (X2) = INPUT LFN                     LEP73270
          MX3       6              (X3) = CHAR EXTRACTION MASK          LEP73280
          SB7       1              (B7) = 1                             LEP73290
LFNBF1     BSS       0                                                  LEP73300
           BX1       X3*X2         ISOLATE CHARACTER IN (X1)            LEP73310
           ZR        X1,LFNBF2     EXIT LOOP ON ZERO BYTE               LEP73320
           BX6      -X3*X6         CLIP MASK                            LEP73330
           SB6       B6-B7         DECREMENT COUNTER                    LEP73340
           LX3       54D           ROTATE (X3) ONE CHAR RIGHT           LEP73350
           GT        B6,LFNBF1     CYCLE IF LESS THAN 7 CHARS PROCESSED LEP73360
LFNBF2    BSS       0                                                   LEP73370
          SA1       =10H           (X1) = BLANK WORD                    LEP73380
          BX2       -X6*X2         CLEAR TRAILING GARBAGE               LEP73390
          SB6       B7+B7          (B6) = 2                             LEP73400
          BX1       X6*X1          CLIP BLANKFILL                       LEP73410
          BX6       X1+X2          FORM RESULT                          LEP73420
          EQ        LFNBF$         RETURN                               LEP73430
LFNBF     BSS       1              FORTRAN-CALLABLE ENTRY               LEP73440
          SA1       X1             (X1) = LFN                      (FTN)LEP73450
          RJ        LFNBF$                                              LEP73460
          EQ        LFNBF                                               LEP73470
LFNINC    SPACE     2                                                   LEP73480
***       LFNINC(LFN)                                                   LEP73490
*                                                                       LEP73500
*         FUNCTION PROC TO INCREMENT LAST CHAR OF LOGICAL FILENAME      LEP73510
*                                                                       LEP73520
          ENTRY     LFNINC                                              LEP73530
LFNINC    BSS       1              ENTRY POINT                          LEP73540
          SA1       X1             (X1) = LFN                      (FTN)LEP73550
          SB7       1              (B7) = 1                             LEP73560
          MX0       -6             (X0) = CHAR EXTRACTION MASK          LEP73570
          SB5       18                                                  LEP73580
          SB6       54                                                  LEP73590
          MX2       18                                                  LEP73600
          AX1       18                                                  LEP73610
          SX7       B7             (X7) = 1                             LEP73620
          BX1       -X2*X1                                              LEP73630
LFNINC1    BSS       0                                                  LEP73640
           BX2       -X0*X1        ISOLATE CHAR IN (X2)                 LEP73650
           NZ        X2,LFNINC2    EXIT LOOP ON NONZERO BYTE            LEP73660
           SB5       B5+6          ADVANCE SHIFT COUNT                  LEP73670
           AX1       6             NEXT CHAR INTO POSITION              LEP73680
           LT        B5,B6,LFNINC1 CYCLE                                LEP73690
LFNINC2   BSS       0                                                   LEP73700
          IX6       X1+X7          FORM RESULT IN (X6)                  LEP73710
          LX6       B5,X6          LEFTJUSTIFY STRING                   LEP73720
          EQ        LFNINC         RETURN                               LEP73730
LFNZF     SPACE     2                                                   LEP73740
***       LFNZF     (LFN)                                               LEP73750
*                                                                       LEP73760
*         FUNCTION PROCEDURE TO ZEROFILL A LFN STRING.  LAST 18         LEP73770
*         BITS ARE NOT MODIFIED.                                        LEP73780
*                                                                       LEP73790
*         FORTRAN REFERENCE -                                           LEP73800
*                                                                       LEP73810
*         LFNZ =    LFNZF (LFN)                                         LEP73820
*                                                                       LEP73830
*         WHERE LFN IS A WORD CONTAINING A LFN STRING DELIMITED         LEP73840
*         BY ZERO BYTE OR A SPECIAL CHARACTER (CODE GT 44B)             LEP73850
*                                                                       LEP73860
*         COMPASS REFERENCE -                                           LEP73870
*                                                                       LEP73880
*         (X1) =    LFN                                                 LEP73890
*         RJ        LFNZF$                                              LEP73900
*                                                                       LEP73910
*         RESULT RETURNS IN THE FUNCTION REGISTER (X6)                  LEP73920
*                                                                       LEP73930
*                                                                       LEP73940
*         REGISTERS USED BY LFNZF$& X0,X2,X3,B2,B3                      LEP73950
*         (B6),(B7) SET TO 2,1, RESP., (B4) RESTORED.                   LEP73960
*                                                                       LEP73970
          ENTRY     LFNZF,LFNZF$                                        LEP73980
LFNZF2    BSS       0                                                   LEP73990
          BX6       -X6*X1         INJECT ZERO FILL                     LEP74000
          SB6       B7+B7          (B6) = 2                             LEP74010
          SB4       X3             RESTORE (B4)                         LEP74020
LFNZF$    BSS       1              COMPASS-CALLABLE ENTRY               LEP74030
          SX3       B4                                                  LEP74040
          MX0       6              (X0) = CHAR EXTRACTION MASK          LEP74050
          SB6       7              (B6) = MAX LFN CHARS                 LEP74060
          SB4       B0                                                  LEP74070
          MX6       42D            42-BIT MASK IN (X6)                  LEP74080
          SB3       1R9            (B3) = 44B FOR SPECIAL CHAR TESTS    LEP74090
          SB7       1              (B7) = 1                             LEP74100
LFNZF1     BSS       0                                                  LEP74110
           BX2       X0*X1         ISOLATE CHAR IN (X2)                 LEP74120
           SB4       B4+6          INCREMENT NOMINAL SHIFT COUNTER      LEP74130
           SB6       B6-B7         DECREMENT CHAR COUNTER               LEP74140
           LX2       B4,X2         RIGHTJUSTIFY CHARACTER               LEP74150
           SB2       X2            (B2) = CHAR TO TEST                  LEP74160
           EQ        B2,LFNZF2     EXIT LOOP ON ZERO BYTE               LEP74170
           GT        B2,B3,LFNZF2  OR SPECIAL CHARACTER                 LEP74180
           BX6       -X0*X6        ZERO WINDOW ON MASK WORD             LEP74190
           LX0       54D           ROTATE (X0) TO NEXT CHAR POSITION    LEP74200
           GT        B6,LFNZF1     CYCLE IF LESS THAN 7 CHARS PROCESSED LEP74210
          EQ        LFNZF2                                              LEP74220
LFNZF     BSS       1              FORTRAN-CALLABLE ENTRY               LEP74230
          SA1       X1             (X1) = LFN                      (FTN)LEP74240
          RJ        LFNZF$                                              LEP74250
          EQ        LFNZF                                               LEP74260
*                                                                       LEP74270
LJRJN     SPACE     2                                                   LEP74280
***       LJRJN  (RJN)                                                  LEP74290
*                                                                       LEP74300
*         TO LEFTJUSTIFY A RIGHTJUSTIFIED NAME STRING                   LEP74310
*                                                                       LEP74320
*         FORTRAN REFERENCE -                                           LEP74330
*                                                                       LEP74340
*         NAME =    LJRJN (RJN)                                         LEP74350
*                                                                       LEP74360
*         WHERE                                                         LEP74370
*                                                                       LEP74380
*         RJN       RIGHTJUSTIFIED TEXTSTRING WITH ZERO/BLANK FILL      LEP74390
*         LJRJN     LEFTJUSTIFIED NAME WITH SAME FILL TYPE              LEP74400
*                                                                       LEP74410
          ENTRY     LJRJN                                               LEP74420
LJRJN     BSS       1                                                   LEP74430
          SA1       X1                                             (FTN)LEP74440
          SB6       10                                                  LEP74450
          MX2       -6                                                  LEP74460
          SB3       1R9                                                 LEP74470
          BX6       X1                                                  LEP74480
          LX1       6                                                   LEP74490
LJRJN1     BSS       0                                                  LEP74500
           BX2       -X2*X1                                             LEP74510
           SB6       B6-1                                               LEP74520
           SB2       X2                                                 LEP74530
           EQ        B2,LJRJN2                                          LEP74540
           LE        B2,B3,LJRJN                                        LEP74550
LJRJN2     LX1       6                                                  LEP74560
           MX2       -6                                                 LEP74570
           LX6       6                                                  LEP74580
           GT        B6,LJRJN1                                          LEP74590
          EQ        LJRJN                                               LEP74600
LMXXXX    SPACE     2                                                   LEP74610
***       LMDLOC (LDI)        LMEQPC(LDI)         LMIFNM(LDI)           LEP74620
***       LMLIMT (LDI)        LMNEXT(LDI)         LMSECT(LDI)           LEP74630
***       LMUNIT (LDI)                                                  LEP74640
*                                                                       LEP74650
*         USER-PROGRAM CALLABLE ENTRIES TO RETRIEVE AST                 LEP74660
*         DATA PERTAINING TO A LOGICAL DEVICE INDEX (LDI)               LEP74670
*                                                                       LEP74680
*         FORTRAN REFERENCE -                                           LEP74690
*         INF =     LM XXXX (LDI)                                       LEP74700
*                                                                       LEP74710
*         WHERE  XXXX = EQPC, DLOC, NEXT, SECT, UNIT  TO RETRIEVE       LEP74720
*         EQUIPMENT CODE, CURRENT DEVICE LOCATION, NEXT FREE            LEP74730
*         LOCATION, SECTOR SIZE, AND UNIT NUMBER, RESPECTIVELY,         LEP74740
*         ASSOCIATED WITH THE LOGICAL DEVICE INDEX LDI.                 LEP74750
*                                                                       LEP74760
*         NOTE -  ONLY LMSECT TESTS FOR LEGAL LDI RANGE.                LEP74770
*                                                                       LEP74780
          ENTRY     LMEQPC,LMDLOC,LMIFNM,LMLIMT,LMNEXT,LMSECT,LMUNIT    LEP74790
LMEQPC    BSS       1                                                   LEP74800
          SA1       X1             (X1) = LDI                      (FTN)LEP74810
          SB1       X1                                                  LEP74820
          SA1       ASTEQC-1+B1                                         LEP74830
          BX6       X1             (X6) = ASTEQC(LDI)                   LEP74840
          EQ        LMEQPC                                              LEP74850
LMDLOC    BSS       1                                                   LEP74860
          SA1       X1             (X1) = LDI                      (FTN)LEP74870
          SB1       X1                                                  LEP74880
          SA1       ASTLOC-1+B1                                         LEP74890
          BX6       X1             (X6) = ASTLOC(LDI)                   LEP74900
          EQ        LMDLOC                                              LEP74910
LMIFNM    BSS       1                                                   LEP74920
          SA1       X1             (X1) = LDI                      (FTN)LEP74930
          SB1       X1                                                  LEP74940
          SA1       ASTLFN-1+B1                                         LEP74950
          RJ        LFNBF$         BLANKFILL LFN                        LEP74960
          EQ        LMIFNM                                              LEP74970
LMNEXT    BSS       1                                                   LEP74980
          SA1       X1             (X1) = LDI                      (FTN)LEP74990
          SB1       X1                                                  LEP75000
          SA1       ASTNXT-1+B1                                         LEP75010
          BX6       X1             (X6) = ASTNXT(LDI)                   LEP75020
          EQ        LMNEXT                                              LEP75030
LMLIMT    BSS       1                                                   LEP75040
          SA1       X1             (X1) = LDI                      (FTN)LEP75050
          SB1       X1                                                  LEP75060
          SA1       ASTLIM-1+B1                                         LEP75070
          BX6       X1             (X6) = ASTLIM(LDI)                   LEP75080
          EQ        LMLIMT                                              LEP75090
LMSECT    BSS       1                                                   LEP75100
          SA1       X1             (X1) = LDI                      (FTN)LEP75110
          SB6       MAXLDI         (B6) = LARGEST ALLOWED LDI           LEP75120
          SB1       X1             (B1) = LDI                           LEP75130
          SX6       -1             (X6) = -1                            LEP75140
          LE        B1,LMSECT      RETURN (X6)=-1  IF LDI LE 0          LEP75150
          GT        B1,B6,LMSECT   RETURN (X6)=-1  IF LDI GT 16         LEP75160
          SA2       ASTEQC-1+B1    (X2) = ASTEQC(LDI)                   LEP75170
          SA3       ASTYPE-1+B1    (X3) = ASTYPE(LDI) = TYPEX+4         LEP75180
          ZR        X2,LMSECT      RETURN (X6)=-1  IF LDI IS INACTIVE   LEP75190
          MX0       -3             (X0) = 57-BIT MASK                   LEP75200
          BX3       -X0*X3         (X3) = TYPEX+4 IN RANGE (0,7)        LEP75210
          SA1       ASTSEC+X3      (X1) = ASTSEC(TYPEX+5)               LEP75220
          BX6       X1             (X6) = SECTOR SIZE                   LEP75230
          EQ        LMSECT         RETURN TO CALLING PROGRAM            LEP75240
LMUNIT    BSS       1                                                   LEP75250
          SA1       X1             (X1) = LDI                      (FTN)LEP75260
          SB1       X1                                                  LEP75270
          SA1       ASTUNT-1+B1                                         LEP75280
          BX6       X1             (X6) = ASTUNT(LDI)                   LEP75290
          EQ        LMUNIT                                              LEP75300
*                                                                       LEP75310
NCOCTL$   SPACE     2                                                   LEP75320
***       NCOCTL$                                                       LEP75330
*                                                                       LEP75340
*         TO CONVERT A 1-9 DIGIT POSITIVE INTEGER TO OCTAL              LEP75350
*         DISPLAY CODE FORMAT                                           LEP75360
*                                                                       LEP75370
*         COMPASS REFERENCE -                                           LEP75380
*                                                                       LEP75390
*         (X1) =    INTEGER TO BE ENCODED                               LEP75400
*         RJ        NCOCTL$                                             LEP75410
*                                                                       LEP75420
*         THE RESULT RETURNS IN (X6)                                    LEP75430
*                                                                       LEP75440
*         REGISTERS USED&   A1,X1,X2,X3,X6                              LEP75450
*         EXIT (B6)=2, (B7)=1                                           LEP75460
*                                                                       LEP75470
          ENTRY     NCOCTL$                                             LEP75480
NCOCTL$   BSS       1              ENTRY/EXIT                           LEP75490
          MX2       -27D                                                LEP75500
          SB6       B0             INITIALIZE BIT COUNTER               LEP75510
          BX2       -X2*X1         LIMIT INTEGER TO 9 OCTAL DIGITS      LEP75520
          MX3       -6             (X3) = RJ CHAR MASK                  LEP75530
          SA1       =10H         B                                      LEP75540
          SB7       6              (B7) = 6                             LEP75550
NCOCTL1    BSS       0                                                  LEP75560
           MX6       -3            (X6) = OCTAL DIGIT MASK              LEP75570
           SB6       B6+B7         ADVANCE BIT COUNT BY 6               LEP75580
           BX6       -X6*X2        ISOLATE OCTAL DIGIT IN (X6)          LEP75590
           LX3       6             POSITION CHAR MASK                   LEP75600
           SX6       X6+1R0        OCTAL DIGIT TO DISPLAY CODE          LEP75610
           BX1       X3*X1         CARVE CHAR WINDOW IN (X1)            LEP75620
           LX6       B6,X6         ROTATE ENCODED DIGIT CHAR            LEP75630
           AX2       3             ALIGN NEXT DIGIT OF SOURCE WORD      LEP75640
           BX1       X1+X6         STUFF ENCODED DIGIT IN RESULT WORD   LEP75650
           NZ        X2,NCOCTL1    CONTINUE IF SOURCE WORD IS NZ        LEP75660
          SB7       1              RESTORE (B7) = 1                     LEP75670
          BX6       X1             PUT RESULT IN (X6)                   LEP75680
          SB6       B7+B7          RESTORE (B6) = 2                     LEP75690
          EQ        NCOCTL$        EXIT                                 LEP75700
RFNBF     SPACE     2                                                   LEP75710
***       RFNBF (RFN)                                                   LEP75720
*                                                                       LEP75730
*         INJECT BLANKFILL IN A ZEROFILLED RIGHTJUSTIFIED FILENAME      LEP75740
*                                                                       LEP75750
*         FORTRAN REFERENCE -                                           LEP75760
*                                                                       LEP75770
*         RFNB =    RFNBF (RFN)                                         LEP75780
*         WHERE                                                         LEP75790
*                                                                       LEP75800
*         RFN       ZERO-FILLED RIGHTJUSTIFIED CHAR STRING              LEP75810
*         RFNBF     SAME AS RFN, WITH 0-FILL REPLACED BY BLANKFILL      LEP75820
*                                                                       LEP75830
*         COMPASS REFERENCE -                                           LEP75840
*                                                                       LEP75850
*         (X1) =    LFN                                                 LEP75860
*         RJ        RFNBF$                                              LEP75870
*                                                                       LEP75880
*         THE RESULT RETURNS IN (X6)                                    LEP75890
*         REGISTERS DESTROYED BY RFNBF$& B6,X1,X2,X3,X4,X6              LEP75900
*                                                                       LEP75910
*                                                                       LEP75920
          ENTRY     RFNBF,RFNBF$                                        LEP75930
RFNBF$    BSS       1              COMPASS-CALLABLE ENTRY POINT         LEP75940
          BX6       X1             INITIALIZE RESULT REGISTER           LEP75950
          MX1       6              (X1) = LJ CHAR MASK                  LEP75960
          SX3       1R             (X3) = FILL CHAR                     LEP75970
          SB6       10             MAX CHARS IN STRING                  LEP75980
          SB7       1              (B7) = 1                             LEP75990
RFNBF1     BSS       0                                                  LEP76000
           BX2       X1*X6         EXTRACT CHARACTER                    LEP76010
           LX1       54D           ROTATE MASK                          LEP76020
           NZ        X2,RFNBF$     EXIT ON NONZERO BYTE                 LEP76030
           LX3       54D                                                LEP76040
           SB6       B6-B7         DECREMENT MAX CHAR COUNTER           LEP76050
           BX6       X3+X6         INSERT BLANK CHARACTER               LEP76060
           GT        B6,RFNBF1     CYCLE                                LEP76070
          EQ        RFNBF$         RETURN                               LEP76080
RFNBF     BSS       1              FORTRAN CALLABLE ENTRY               LEP76090
          SA1       X1             (X1) = LFN                      (FTN)LEP76100
          RJ        RFNBF$                                              LEP76110
          EQ        RFNBF                                               LEP76120
*                                                                       LEP76130
          END                                                           LEP76140
*DECK       IOMPFM                                                      LEP76150
* =DECK      IOMPFM      IOMPFM      ASSEMBLY                           LEP76160
          IDENT     IOMPFM                                              LEP76170
          TITLE     PERMANENT FILE MANAGEMENT FUNCTIONS                 LEP76180
ASMCNTL   SPACE     3                                                   LEP76190
*CALL       IOMACTL                                                     LEP76200
          IFEQ      OS,NOS         *                                    LEP76210
************************************                               (NOS)LEP76220
*    EXTERNAL TEXT COMMON DECKS    *                               (NOS)LEP76230
************************************                               (NOS)LEP76240
*         LIST      X              *                               (NOS)LEP76250
          XTEXT     COMCSYS        *  SYSTEM REQUEST ROUTINES      (NOS)LEP76260
          XTEXT     COMCPFM        *                               (NOS)LEP76270
          ENDIF                    *                                    LEP76280
************************************                                    LEP76290
COMMON    SPACE     2                                                   LEP76300
***       COMMON BLOCK DECLARATION                                      LEP76310
*                                                                       LEP76320
* =PROCEDURE CDMASTA                                                    LEP76330
*CALL        CDMASTA                                                    LEP76340
          USE       0                                                   LEP76350
SUMMARY   SPACE     3                                                   LEP76360
************************************************************************LEP76370
*                                                                      *LEP76380
*         PERMANENT FILE FUNCTIONS PROVIDE FOR RUNTIME EXECUTION       *LEP76390
*         OF BASIC OPERATIONS PERTAINING TO THE ACTIVITY/STATUS        *LEP76400
*         OF DATA FILES RESIDING ON PERMANENT DEVICES.                 *LEP76410
*                                                                      *LEP76420
*         PROGRAMMED BY C.A. FELIPPA, DEC 1975                         *LEP76430
*                                                                      *LEP76440
*         UPDATE -  NOV 1977                                           *LEP76450
*                                                                      *LEP76460
************************************************************************LEP76470
*                                                                      *LEP76480
*         A SUMMARY DESCRIPTION FOLLOWS.                               *LEP76490
*                                                                      *LEP76500
*         IOMAPF    ATTACH PERMANENT FILE TO JOB  (SCOPE/NOS)          *LEP76510
*                                                                      *LEP76520
*         IOMCPF    CATALOG PERMANENT FILE (SCOPE)                     *LEP76530
*                                                                      *LEP76540
*         IOMDPF    DEFINE DIRECT-ACCESS PERMANENT FILE (NOS)          *LEP76550
*                                                                      *LEP76560
*         IOMEPF    EXTEND PERMANENT FILE (SCOPE)                      *LEP76570
*                                                                      *LEP76580
*         IOMPPF    PURGES PERMANENT FILE (SCOPE/NOS)                  *LEP76590
*                                                                      *LEP76600
*         IOMRPF    REQUESTS EQUIPMENT APPROPRIATE AS RESIDENCE        *LEP76610
*                   MEDIUM FOR A  PERMANENT FILE (SCOPE)               *LEP76620
*                                                                      *LEP76630
************************************************************************LEP76640
IOMAPF    SPACE     2                                                   LEP76650
***       IOMAPF    (LFN, PFN, ID, MR)                           (SCOPE)LEP76660
***       IOMAPF    (LFN, PFN, UN, M)                              (NOS)LEP76670
*                                                                       LEP76680
*         ENTRY POINT TO ATTACH A PERMANENT FILE TO RUN                 LEP76690
*                                                                       LEP76700
*         FORTRAN REFERENCE (SCOPE) -                                   LEP76710
*                                                                       LEP76720
*         CALL   IOMAPF  (LFN, PFN, ID, M)                              LEP76730
*                                                                       LEP76740
*         WHERE                                                         LEP76750
*                                                                       LEP76760
*         LFN       LOGICAL FILENAME                                    LEP76770
*                                                                       LEP76780
*         PFN       42/PFN,6/0,6/RP,6/CY, AS IN IOMCPF.                 LEP76790
*                                                                       LEP76800
*         ID        OPTIONAL OWNERS ID, AS IN IOMCPF.                   LEP76810
*                                                                       LEP76820
*         M         FILE ACCESS MODE PARAMETER                          LEP76830
*                    -1   MULTIREAD ACCESS (SAME AS MR=1 ON CC)         LEP76840
*                    +1   EXCLUSIVE ACCESS (SAME AS RW=0 ON CC)         LEP76850
*                     0   THIS ARGUMENT IS IGNORED                      LEP76860
*                                                                       LEP76870
*         FORTRAN REFERENCE (NOS) -                                     LEP76880
*                                                                       LEP76890
*         CALL   IOMAPF  (LFN, PFN, UN, M)                              LEP76900
*                                                                       LEP76910
*         WHERE                                                         LEP76920
*                                                                       LEP76930
*         LFN,PFN   SAME AS ABOVE.  HOWEVER, RP AND CY FIELDS IN        LEP76940
*                   PFN WORD ARE IGNORED.                               LEP76950
*                                                                       LEP76960
*         UN        OPTIONAL USERS NUMBER OR ID.  IF ZERO, THIS         LEP76970
*                   PARAMETER IS IGNORED.                               LEP76980
*                                                                       LEP76990
*         M         FILE ACCESS MODE, AS IN IOMDPF.                     LEP77000
*                                                                       LEP77010
          ENTRY     IOMAPF                                              LEP77020
IOMAPF    BSS       1              ENTRY/EXIT POINT                     LEP77030
APFSYST   IFEQ      OS,SCOPE                                            LEP77040
          SB5       -1             MARK ATTACH ENTRY             (SCOPE)LEP77050
          RJ        FDBSET         INITIALIZE FILE DEF BLOCK     (SCOPE)LEP77060
          SX7       11B                                            (SCOPLEP77070
          ZR        X4,ATTPF1                                      (SCOPLEP77080
          SX7       033B           SET EXCLUSIVE ACCESS          (SCOPE)LEP77090
          PL        X4,ATTPF1      TEST FOR M=1                  (SCOPE)LEP77100
          SX7       111B           SET MULTIREAD ACCESS FLAG     (SCOPE)LEP77110
ATTPF1    BSS       0                                            (SCOPE)LEP77120
          SA7       A7+B7          STORE ACCESS MODE DESCRIPTOR  (SCOPE)LEP77130
+         SA5       =7HATTACH,                                   (SCOPE)LEP77140
          RJ        PFMESG         PRINT INFORMATIVE MESSAGE     (SCOPE)LEP77150
          ATTACH    FDB,RC         ATTACH MACRO                  (SCOPE)LEP77160
+         SA2       IOMAPF         FETCH RETURN INSTRUCTION      (SCOPE)LEP77170
          EQ        PFMEXIT        GET RETURN CODE AND EXIT      (SCOPE)LEP77180
APFSYST   ELSE                                                          LEP77190
          SB5       -1             MARK ATTACH ENTRY               (NOS)LEP77200
          RJ        PFMFET         INITIALIZE FET FOR PFM REQUESTS (NOS)LEP77210
          MX6       0                                              (NOS)LEP77220
          BX7       X4             (X7) = M                        (NOS)LEP77230
          SA6       UNW            CLEAR UN                        (NOS)LEP77240
          SA7       AMW            STORE M                         (NOS)LEP77250
          ZR        X3,ATTPF3                                      (NOS)LEP77260
          BX6       X3                                             (NOS)LEP77270
          BX1       X3             (X6) = UN                       (NOS)LEP77280
          SA6       RJUNW                                          (NOS)LEP77290
          SX1       A6                                             (NOS)LEP77300
          RJ        =XLJRJN                                        (NOS)LEP77310
          SA6       UNW                                            (NOS)LEP77320
          SB1       RJUNW                                          (NOS)LEP77330
ATTPF3    BSS       0                                                   LEP77340
+         SA5       =7HATTACH,                                     (NOS)LEP77350
          RJ        PFMESG         PRINT INFORMATIVE MESSAGE       (NOS)LEP77360
          ATTACH    FET,,UNW,,AMW  ATTACH MACRO                    (NOS)LEP77370
+         SA2       IOMAPF         FETCH RETURN INSTRUCTION        (NOS)LEP77380
          EQ        PFMEXIT        GET RETURN CODE AND EXIT        (NOS)LEP77390
APFSYST   ENDIF                                                         LEP77400
IOMCPF    SPACE     2                                                   LEP77410
***       IOMCPF  (LFN, PFN, ID, XR)                             (SCOPE)LEP77420
*                                                                       LEP77430
*         ENTRY POINT TO CATALOG A PERMANENT FILE (SCOPE ONLY)          LEP77440
*                                                                       LEP77450
*         FORTRAN REFERENCE -                                           LEP77460
*                                                                       LEP77470
*         CALL   IOMCPF  (LFN, PFN, ID, XR)                             LEP77480
*                                                                       LEP77490
*         WHERE                                                         LEP77500
*                                                                       LEP77510
*         LFN       LOGICAL FILENAME (1-7 ALPHANUMERIC CHARS,           LEP77520
*                   LEFTJUSTIFIED, ZEROFILLED). MUST BE                 LEP77530
*                   CURRENTLY ATTACHED TO JOB.                          LEP77540
*                                                                       LEP77550
*         PFN       42/PFN,6/0,6/RP,6/CY      WHERE                     LEP77560
*                   PFN    PERMANENT FILENAME (SAME RESTRICTIONS        LEP77570
*                          AS FOR LFN)                                  LEP77580
*                   CY     CYCLE NUMBER (1-63). IF ZERO, THE O/S        LEP77590
*                          WILL ASSUME CY = (HIGHEST CAT CY) + 1        LEP77600
*                   RP     RETENTION PERIOD IN DAYS.  IF 0, THE         LEP77610
*                          PROGRAM ASSUMES RP=30 DAYS.                  LEP77620
*                                                                       LEP77630
*         ID        OPTIONAL OWNERS ID (1 TO 7 CHARS, RJ WITH           LEP77640
*                   ZERO FILL).  IF ZERO, THIS SPEC IS IGNORED.         LEP77650
*                                                                       LEP77660
*         XR        IF NONZERO, PROGRAM ASSUMES THAT THIS IS A          LEP77670
*                   CONTROL/MODIFY/EXTEND PASSWORD (1-7 CHARS,          LEP77680
*                   RIGHTJUSTIFIED W/ZERO FILL). IGNORED IF ZERO        LEP77690
*                                                                       LEP77700
          ENTRY     IOMCPF                                              LEP77710
IOMCPF    BSS       1              ENTRY/EXIT POINT                     LEP77720
CPFSYST   IFEQ      OS,SCOPE                                            LEP77730
          SB5       1              MARK CATALOG ENTRY            (SCOPE)LEP77740
          RJ        FDBSET         INITIALIZE FILE DEF BLOCK     (SCOPE)LEP77750
          SX2       13B            (X2) = CODE FOR XR DESCRIPTOR (SCOPE)LEP77760
          BX4       -X0*X4         (X4) = MASKED XR STRING       (SCOPE)LEP77770
          LX4       6              ROTATE XR                     (SCOPE)LEP77780
          ZR        X4,CATPF1      OMIT XR SPEC IF XR=0          (SCOPE)LEP77790
          BX7       X4+X2          FORM DESCRIPTOR IN (X7)       (SCOPE)LEP77800
          SA7       A7+B7          STORE XR SPEC                 (SCOPE)LEP77810
CATPF1    BSS       0                                            (SCOPE)LEP77820
+         SA5       =9HCATALOG,                                  (SCOPE)LEP77830
          RJ        PFMESG         PRINT INFORMATIVE MESSAGE     (SCOPE)LEP77840
          CATALOG   FDB,RC         CATALOG MACRO                 (SCOPE)LEP77850
+         SA2       IOMCPF         FETCH RETURN INSTRUCTION      (SCOPE)LEP77860
          EQ        PFMEXIT        GET RETURN CODE AND EXIT      (SCOPE)LEP77870
CPFSYST   ELSE                                                          LEP77880
          EQ        IOMCPF                                         (NOS)LEP77890
CPFSYST   ENDIF                                                         LEP77900
IOMDPF    SPACE     2                                                   LEP77910
***       IOMDPF   (LFN, PFN, CT, M)                               (NOS)LEP77920
*                                                                       LEP77930
*         ENTRY POINT TO DEFINE A (DIRECT ACCESS) PERMANENT FILE.       LEP77940
*         (NOS SYSTEM ONLY)                                             LEP77950
*                                                                       LEP77960
*         FORTRAN REFERENCE -                                           LEP77970
*                                                                       LEP77980
*         CALL   IOMDPF  (LFN, PFN, CT, M)                              LEP77990
*                                                                       LEP78000
*         WHERE                                                         LEP78010
*                                                                       LEP78020
*         LFN       LOGICAL FILENAME, AS IN IOMCPF.                     LEP78030
*                                                                       LEP78040
*         PFN       42/PFN,6/0,6/RP,6/CY.  CY,RP ARE IGNORED UNDER NOS. LEP78050
*                                                                       LEP78060
*         CT        FILE CATEGORY OCTAL VALUE (CF. NOS MANUAL)          LEP78070
*                                                                       LEP78080
*         M         FILE ACCESS MODE OR PERMISSION LEVEL                LEP78090
*                   OCTAL VALUE (CF. NOS MANUAL)                        LEP78100
*                                                                       LEP78110
          ENTRY     IOMDPF                                              LEP78120
IOMDPF    BSSZ      1              ENTRY/EXIT POINT                     LEP78130
DPFSYST   IFEQ      OS,SCOPE                                            LEP78140
          EQ        IOMDPF                                       (SCOPE)LEP78150
DPFSYST   ELSE                                                          LEP78160
          SB5       1              MARK DEFINE ENTRY               (NOS)LEP78170
          RJ        PFMFET         INITIALIZE FET FOR PFM REQUESTS (NOS)LEP78180
          BX6       X3             (X6) = CT                       (NOS)LEP78190
          LX7       X4             (X7) = M                        (NOS)LEP78200
          SA6       CTW            STORE CT                        (NOS)LEP78210
          SA7       AMW            STORE M                         (NOS)LEP78220
+         SA5       =7HDEFINE,     (X5) = OPERATION ID             (NOS)LEP78230
          RJ        PFMESG         PRINT INFORMATIVE MESSAGE       (NOS)LEP78240
          DEFINE    FET,,,,,CTW,AMW                                (NOS)LEP78250
+         SA2       IOMDPF         FETCH RETURN INSTRUCTION        (NOS)LEP78260
          EQ        PFMEXIT        GET RETURN CODE AND EXIT        (NOS)LEP78270
DPFSYST   ENDIF                                                         LEP78280
*                                                                       LEP78290
IOMEPF    SPACE     2                                                   LEP78300
***       IOMEPF    (LFN, PFN, ID, 0)                                   LEP78310
*                                                                       LEP78320
*         ENTRY POINT TO EXTEND A PERMANENT FILE  (SCOPE ONLY)          LEP78330
*                                                                       LEP78340
*         FORTRAN REFERENCE -                                           LEP78350
*                                                                       LEP78360
*         CALL   IOMEPF  (LFN, PFN, ID, 0)                              LEP78370
*                                                                       LEP78380
*         WHERE                                                         LEP78390
*                                                                       LEP78400
*         LFN,PFN,ID     SAME AS FOR IOMCPF/IOMAPF                      LEP78410
*                                                                       LEP78420
          ENTRY     IOMEPF                                              LEP78430
IOMEPF    BSS       1              ENTRY/EXIT POINT                     LEP78440
EPFSYST   IFEQ      OS,SCOPE                                            LEP78450
          SB5       B0             MARK EXTEND/PURGE ENTRY       (SCOPE)LEP78460
          RJ        FDBSET         INITIALIZE FILE DEF BLOCK     (SCOPE)LEP78470
+         SA5       =7HEXTEND,     (X5) = OPER ID                (SCOPE)LEP78480
          RJ        PFMESG         PRINT INFORMATIVE MESSAGE     (SCOPE)LEP78490
          EXTEND    FDB,RC         EXTEND MACRO                  (SCOPE)LEP78500
          SA2       IOMEPF         FETCH RETURN INSTRUCTION      (SCOPE)LEP78510
          EQ        PFMEXIT        GET RETURN CODE AND EXIT      (SCOPE)LEP78520
EPFSYST   ELSE                                                          LEP78530
          EQ        IOMEPF                                         (NOS)LEP78540
EPFSYST   ENDIF                                                         LEP78550
*                                                                       LEP78560
IOMPPF    SPACE     2                                                   LEP78570
***       IOMPPF    (LFN, PFN, ID, 0)                            (SCOPE)LEP78580
***       IOMPPF    (LFN, PFN, UN, PW)                             (NOS)LEP78590
*                                                                       LEP78600
*         ENTRY POINT TO PURGE AN ATTACHED PERMANENT FILE               LEP78610
*                                                                       LEP78620
*         FORTRAN REFERENCE (SCOPE) -                                   LEP78630
*                                                                       LEP78640
*         CALL   IOMPPF  (LFN, PFN, ID, 0)                              LEP78650
*                                                                       LEP78660
*         WHERE                                                         LEP78670
*                                                                       LEP78680
*         LFN,PFN,ID     SAME AS FOR IOMCPF/IOMAPF                      LEP78690
*                   LFN MUST BE CURRENTLY ATTACHED TO JOB.              LEP78700
*                                                                       LEP78710
*         FORTRAN REFERENCE (NOS) -                                     LEP78720
*         CALL   IOMPPF  (LFN, PFN, UN, 0)                              LEP78730
*                                                                       LEP78740
*         WHERE                                                         LEP78750
*                                                                       LEP78760
*         LFN,PFN   SAME AS ABOVE                                       LEP78770
*         UN        USERS NUMBER                                        LEP78780
*                                                                       LEP78790
          ENTRY     IOMPPF                                              LEP78800
IOMPPF    BSS       1              ENTRY/EXIT POINT                     LEP78810
PPFSYST   IFEQ      OS,SCOPE                                            LEP78820
          SB5       B0             MARK EXTEND/PURGE ENTRY       (SCOPE)LEP78830
          RJ        FDBSET         INITIALIZE FILE DEF BLOCK     (SCOPE)LEP78840
+         SA5       =6HPURGE,      (X5) = OPER ID                (SCOPE)LEP78850
          RJ        PFMESG         PRINT INFORMATIVE MESSAGE     (SCOPE)LEP78860
          PURGE     FDB,RC         PURGE MACRO                   (SCOPE)LEP78870
          SA2       IOMPPF         FETCH RETURN INSTRUCTION      (SCOPE)LEP78880
          EQ        PFMEXIT        GET RETURN CODE AND EXIT      (SCOPE)LEP78890
PPFSYST   ELSE                                                          LEP78900
          RJ        PFMFET         INITIALIZE FET FOR PFM REQUESTS (NOS)LEP78910
+         SA5       =6HPURGE,      (X5) = OPER ID                  (NOS)LEP78920
          RJ        PFMESG         PRINT INFORMATIVE MESSAGE       (NOS)LEP78930
          PURGE     FET                                            (NOS)LEP78940
          SA2       IOMPPF         FETCH RETURN INSTRUCTION        (NOS)LEP78950
          EQ        PFMEXIT        GET RETURN CODE AND EXIT        (NOS)LEP78960
PPFSYST   ENDIF                                                         LEP78970
*                                                                       LEP78980
IOMRPF    SPACE      2                                                  LEP78990
***       IOMRPF    (LFN)                                               LEP79000
*                                                                       LEP79010
*         ENTRY POINT TO REQUEST EQUIPMENT APPROPRIATE TO               LEP79020
*         PERMANENT FILE (SCOPE ONLY)                                   LEP79030
*                                                                       LEP79040
*         FORTRAN REFERENCE -                                           LEP79050
*                                                                       LEP79060
*         CALL   IOMRPF  (LFN)                                          LEP79070
*                                                                       LEP79080
*         WHERE LFN IS THE LOGICAL FILENAME OF THE PERM FILE.           LEP79090
*                                                                       LEP79100
          ENTRY     IOMRPF                                              LEP79110
IOMRPF    BSS       1                                                   LEP79120
RPFSYST   IFEQ      OS,SCOPE                                            LEP79130
          SB7       1                                            (SCOPE)LEP79140
          MX7       0                                            (SCOPE)LEP79150
          SA1       X1             (X1) = LFN                    (SCOPE)LEP79160
          SA7       FET+8          CLEAR FET(9)                  (SCOPE)LEP79170
          MX0       42D                                          (SCOPE)LEP79180
          SA7       A7-B7          CLEAR FET(8)                  (SCOPE)LEP79190
          SB1       B0                                           (SCOPE)LEP79200
          SA7       A7-B7          CLEAR FET(7)                  (SCOPE)LEP79210
          SB2       B0                                           (SCOPE)LEP79220
          SA7       A7-B7          CLEAR FET(6)                  (SCOPE)LEP79230
          SA3       REQPFW         (X3) = *PF REQUEST WORD       (SCOPE)LEP79240
          SA7       A7-B7          CLEAR FET(5)                  (SCOPE)LEP79250
          SB3       B0                                           (SCOPE)LEP79260
          SA7       A7-B7          CLEAR FET(4)                  (SCOPE)LEP79270
          SA2       =3L*PF         (A2) = ADDRESS(DUMMY PFN)     (SCOPE)LEP79280
          BX6       X0*X1          (X6) = MASKED LFN             (SCOPE)LEP79290
          SA7       A7-B7          CLEAR FET(3)                  (SCOPE)LEP79300
          BX7       X3             (X7) = FLAG WORD              (SCOPE)LEP79310
          SA7       A7-B7          SET FET(2)                    (SCOPE)LEP79320
          SA6       A7-B7          SET FET(1)                    (SCOPE)LEP79330
          SA5       =8HREQUEST,    (X5) = OPERATION ID           (SCOPE)LEP79340
          RJ        PFMESG                                       (SCOPE)LEP79350
          REQUEST   FET            ISSUE REQUEST                 (SCOPE)LEP79360
          SA2       IOMRPF         GET RETURN INSTRUCTION        (SCOPE)LEP79370
          EQ        RPFEXIT        GET RETURN CODE AND EXIT      (SCOPE)LEP79380
REQPFW    VFD       29/1,3/1,28/0            REQUEST,LFN,*PF     (SCOPE)LEP79390
RPFSYST   ELSE                                                          LEP79400
          EQ        IOMRPF                                         (NOS)LEP79410
RPFSYST   ENDIF                                                         LEP79420
FDBSET    SPACE     2                                                   LEP79430
*                                                                       LEP79440
**        UTILITY CODE BLOCK TO INITIALIZE FILE DEFINITION BLOCK        LEP79450
*                                                                       LEP79460
*         ENTRY -   (B5) = FUNCTION FLAG&  1=CATALOG/DEFINE,            LEP79470
*                   -1=ATTACH, 0=EXTEND/PURGE.                          LEP79480
*         EXIT -    (B7)=1, (B6)=2, LFN/PFN STORED,                     LEP79490
*                   (A1)=ADDRESS(LFN), (A2)=ADDRESS(PFN),               LEP79500
*                   (A7) = ADDRESS OF LAST PARAMETER STORED,            LEP79510
*                   (X3) = VALUE OF 3RD ARGUMENT.                       LEP79520
*                   (X4) = VALUE OF 4TH ARGUMENT.                       LEP79530
*                   (B1)/(B2)/(B3)  ADRRESSES OF ID/CY/RP DESCR         LEP79540
*                   WORDS, RESP., IF IN FDB, ELSE ZERO.                 LEP79550
*                   (X0) = 18-BIT MASK                                  LEP79560
*                                                                       LEP79570
FDBPFN    EQU       FET            PFN (SCOPE)                          LEP79580
FDB       EQU       FET+4          LFN/RETURN-CODE/REQUEST-CODE (SCOPE) LEP79590
PFMFET    BSS       0                                                   LEP79600
FDBSET    BSS       1                                                   LEP79610
FDBSYST   IFEQ      OS,SCOPE                                            LEP79620
          SA5       =55555555555555550000B                       (SCOPE)LEP79630
          SB7       1              (B7) = 1                      (SCOPE)LEP79640
          MX6       0              (X6) = 0                      (SCOPE)LEP79650
          BX7       X5             (X7) = TERMINATOR WORD        (SCOPE)LEP79660
          SA6       FDB-1                                        (SCOPE)LEP79670
          SB6       B7+B7          (B6) = 2                      (SCOPE)LEP79680
          SA7       A6+B6                                        (SCOPE)LEP79690
          SA6       A6-B7                                        (SCOPE)LEP79700
          SA7       A7+B7                                        (SCOPE)LEP79710
          SA6       A6-B7                                        (SCOPE)LEP79720
          SA7       A7+B7                                        (SCOPE)LEP79730
          MX0       42D            (X0) = FILENAME MASK          (SCOPE)LEP79740
          SA7       A7+B7                                        (SCOPE)LEP79750
          SA7       A7+B7                                        (SCOPE)LEP79760
          SA2       A1+B7                                          (FTN)LEP79770
          SA3       A1+B6                                          (FTN)LEP79780
          SA4       A2+B6                                          (FTN)LEP79790
          SA1       X1             (X1) = LFN                      (FTN)LEP79800
          SA2       X2             (X2) = PFN                      (FTN)LEP79810
          SA3       X3             (X3) = ID                       (FTN)LEP79820
          SA4       X4             (X4) = 4TH ARG VALUE            (FTN)LEP79830
          BX7       X0*X1          (X7) = MASKED LFN             (SCOPE)LEP79840
          BX6       X0*X2          (X6) = MASKED PFN             (SCOPE)LEP79850
          SA7       FDB            STORE LFN                     (SCOPE)LEP79860
          SA6       A6-B7          STORE PFN                     (SCOPE)LEP79870
          BX5      -X0*X2          (X5) = RP/CY FIELDS           (SCOPE)LEP79880
          MX0       -42D                                         (SCOPE)LEP79890
          SB1       B0             (B1) = 0                      (SCOPE)LEP79900
          BX3       -X0*X3                                       (SCOPE)LEP79910
          SX7       14B            (X7) = CODE FOR ID-WORD       (SCOPE)LEP79920
          LX3       6              ROTATE ID STRING              (SCOPE)LEP79930
          SA1       A7             (A1) = ADDRESS(LFN) IN FDB    (SCOPE)LEP79940
          SA2       A6             (A2) = ADDRESS(PFN) IN FDB    (SCOPE)LEP79950
          ZR        X3,FDBSET1     OMIT ID SPEC IF ID=0          (SCOPE)LEP79960
          BX7       X3+X7          INSERT ID CODE                (SCOPE)LEP79970
          SA7       A7+B7          STORE ID SPEC                 (SCOPE)LEP79980
          SB1       A7             (B1) = ADDRESS(ID-DESCRIPTOR) (SCOPE)LEP79990
FDBSET1   BSS       0                                            (SCOPE)LEP80000
          MX0       -6                                           (SCOPE)LEP80010
          BX7       -X0*X5         (X7) = CY FIELD               (SCOPE)LEP80020
          SB2       B0             (B2) = 0                      (SCOPE)LEP80030
          LX7       6              POSITION CY VALUE             (SCOPE)LEP80040
          EQ        B5,FDBSET2     IGNORE CY ON EXTEND/PURGE     (SCOPE)LEP80050
          ZR        X7,FDBSET2     OR IF CY = 0                  (SCOPE)LEP80060
          SX7       X7+3           INSERT CY IDENTIFIER  (03B)   (SCOPE)LEP80070
          SA7       A7+B7          STORE CYCLE DESCRIPTOR WORD   (SCOPE)LEP80080
          SB2       A7             (B2) = ADDRESS(CY-DESCRIPTOR) (SCOPE)LEP80090
FDBSET2   BSS       0                                            (SCOPE)LEP80100
          AX5       6              RIGHTJUSTIFY RP FIELD         (SCOPE)LEP80110
          BX7       -X0*X5         (X7) = RP                     (SCOPE)LEP80120
          SB3       B0             (B3) = 0                      (SCOPE)LEP80130
          LX7       6                                            (SCOPE)LEP80140
          LE        B5,FDBSET4     IGNORE RP EXCEPT FOR CATALOG  (SCOPE)LEP80150
          NZ        X7,FDBSET3     TEST FOR NONZERO RP           (SCOPE)LEP80160
          SX7       3600B          IF RP=0, SET RP = 30 DAYS     (SCOPE)LEP80170
FDBSET3   BSS       0                                            (SCOPE)LEP80180
          SX7       X7+2           INSERT RP IDENTIFIER (02B)    (SCOPE)LEP80190
          SA7       A7+B7          STORE RP DESCRIPTOR           (SCOPE)LEP80200
          SB3       A7             (B3) = ADDRESS(RP-DESCRIPTOR) (SCOPE)LEP80210
FDBSET4   BSS       0                                            (SCOPE)LEP80220
          MX0       -42D                                         (SCOPE)LEP80230
FDBSYST   ELSE                                                          LEP80240
          MX6       0              (X6) = 0                        (NOS)LEP80250
          SB7       1              (B7) = 1                        (NOS)LEP80260
          MX7       0              (X7) = 0                        (NOS)LEP80270
          SB6       B7+B7          (B6) = 2                        (NOS)LEP80280
          SA6       FET+1          CLEAR FET(2)                    (NOS)LEP80290
          SA7       A6+B7          CLEAR FET(3)                    (NOS)LEP80300
          SA6       A6+B6          CLEAR FET(4)                    (NOS)LEP80310
          SA7       A7+B6          CLEAR FET(5)                    (NOS)LEP80320
          SA6       A6+B6          CLEAR FET(6)                    (NOS)LEP80330
          SA7       A7+B6          CLEAR FET(7)                    (NOS)LEP80340
          SA6       A6+B6          CLEAR FET(8)                    (NOS)LEP80350
          MX0       42D                                            (NOS)LEP80360
          SA2       A1+B7                                          (FTN)LEP80370
          SA1       X1             (X1) = LFN                      (FTN)LEP80380
          SA3       A2+B7                                          (FTN)LEP80390
          SA2       X2             (X2) = PFN                      (FTN)LEP80400
          SA4       A3+B7                                          (FTN)LEP80410
          SA3       X3             (X3) = 3RD ARGUMENT             (FTN)LEP80420
          SA4       X4             (X4) = 4TH ARGUMENT             (FTN)LEP80430
          BX7       X0*X1          (X7) = MASKED LFN               (NOS)LEP80440
          BX6       X0*X2          (X6) = MASKED PFN               (NOS)LEP80450
          SX5       B7                                             (NOS)LEP80460
          SB1       B0             (B1) = 0                        (NOS)LEP80470
          BX7       X5+X7          SET FET ACTIVITY BIT ON         (NOS)LEP80480
          SA1       FETW1                                          (NOS)LEP80490
          SA7       FET            STORE LFN                       (NOS)LEP80500
          SA6       FET+8          STORE PFN                       (NOS)LEP80510
          BX6       X1                                             (NOS)LEP80520
          SA6       A7+B7          STORE FET+1                     (NOS)LEP80530
          EQ        PFMFET         RETURN TO APPROPRIATE PROCEDURE (NOS)LEP80540
FETW1     VFD       15/0,1/1,20/0,6/7,18/0     EP=1, FETLGTH=5+7   (NOS)LEP80550
FDBSYST   ENDIF                                                         LEP80560
          EQ        FDBSET         RETURN TO APPROPRIATE ENTRY          LEP80570
PFMESG    SPACE     2                                                   LEP80580
*                                                                       LEP80590
**        CODE BLOCK TO GENERATE AND PRINT INFORMATIVE MESSAGE          LEP80600
*                                                                       LEP80610
*         ENTRY REGISTER SET -                                          LEP80620
*         (A1)=ADDRESS(LFN), (A2)=ADDRESS(PFN)                          LEP80630
*         (B1),(B2),(B3),(B7) -  SEE FDBSET                             LEP80640
*         (X5) = OPERATION ID TEXT.                                     LEP80650
*         EXIT -    (B1)=1, ALL OTHERS DESTROYED.                       LEP80660
*                                                                       LEP80670
PFMESG    BSS       1                                                   LEP80680
          SA4       =6H0+++                                             LEP80690
          IFEQ      OS,SCOPE                                            LEP80700
          SA1       A1             (X1) = LFN                    (SCOPE)LEP80710
          ELSE                                                          LEP80720
          SA1       FET            (X1) = LFN                      (NOS)LEP80730
          ENDIF                                                         LEP80740
          LX7       X5                                                  LEP80750
          BX6       X4                                                  LEP80760
          SA7       ASTMSG+1       OPERATION ID TO ASTMSG(2)            LEP80770
          SA6       A7-B7          INITIALIZE ASTMSG(1)                 LEP80780
          SX4       1R,                                                 LEP80790
          RJ        =XLFNBF$       BLANKFILL LFN IN (X6)                LEP80800
          MX0       6                                                   LEP80810
          LX4       12D                                                 LEP80820
          LX0       18D                                                 LEP80830
          BX7       -X0*X6                                              LEP80840
          IFEQ      OS,SCOPE                                            LEP80850
          SA1       A2             (X1) = PFN                    (SCOPE)LEP80860
          ELSE                                                          LEP80870
          SA1       FET+8          (X1) = PFN                      (NOS)LEP80880
          ENDIF                                                         LEP80890
          BX7       X4+X7          INSERT COMMA AFTER LFN               LEP80900
          RJ        =XLFNBF$       BLANKFILL PFN IN (X6)                LEP80910
          SA7       A7+B7          STORE LFN IN ASTMSG(3)               LEP80920
          BX7       X6             (X7) = PFN                           LEP80930
          MX0       -6                                                  LEP80940
          SA7       A7+B7          STORE PFN IN ASTMSG(4)               LEP80950
          EQ        B1,PFMSG1      SKIP IF NO ID STORED                 LEP80960
          SX4       1R*                                                 LEP80970
          SA1       B1             (X1) = ID DESCRIPTOR WORD            LEP80980
          RJ        =XRFNBF$       BLANKFILL PFN-ID IN (X6)             LEP80990
          MX0       -6                                                  LEP81000
          BX6       X0*X6          CLEAR SLOT FOR *                     LEP81010
          BX6       X6+X4          INSERT ASTERISK                      LEP81020
          SA6       A7             STORE PFN-ID IN ASTMSG(4)            LEP81030
          SA7       A7+B7          STORE PFN INTO  ASTMSG(5)            LEP81040
PFMSG1    BSS       0                                                   LEP81050
          IFEQ      OS,SCOPE                                            LEP81060
          EQ        B2,PFMSG2      OMIT CY PRINT IF (B2)=0              LEP81070
          SA1       B2             (X1) = CY DESCRIPTOR WORD            LEP81080
          AX1       6              RIGHTJUSTIFY CYCLE NO.               LEP81090
          SA5       =7L,  CY=                                           LEP81100
          RJ        =XNCOCTL$      CONVERT TO DISPLAY CODE IN (X6)      LEP81110
          MX0       -18D                                                LEP81120
          BX6       -X0*X6                                              LEP81130
          BX7       X5+X6          (X7) NOW HAS 10H,  CY = XXB          LEP81140
          SA7       A7+B7          STORE CY LABEL WORD                  LEP81150
PFMSG2    BSS       0                                                   LEP81160
          EQ        B3,PFMSG3      OMIT RP PRINT IF (B3)=0              LEP81170
          SA1       B3             (X1) = RP DESCRIPTOR WORD            LEP81180
          AX1       6              RIGHTJUSTIFY RP VALUE                LEP81190
          SA5       =7L,  RP=                                           LEP81200
          RJ        =XNCOCTL$      CONVERT TO DISPLAY CODE IN (X6)      LEP81210
          MX0       -18D                                                LEP81220
          BX6       -X0*X6                                              LEP81230
          BX7       X5+X6          (X7) NOW HAS 10H,  RP = XXB          LEP81240
          SA7       A7+B7          STORE RP LABEL WORD                  LEP81250
PFMSG3    BSS       0                                                   LEP81260
          ENDIF                                                         LEP81270
          RJ        =XIOMESSG      PRINT MESSAGE                        LEP81280
          SB1       1              SET (B1) = 1                         LEP81290
          EQ        PFMESG         RETURN TO APPROPRIATE MACRO          LEP81300
*                                                                       LEP81310
*                                                                       LEP81320
**        UTILITY CODE BLOCK FOR TERMINATION ACTIVITIES                 LEP81330
*                                                                       LEP81340
*         ENTRY -   (X2) = RETURN INSTRUCTION                           LEP81350
*                                                                       LEP81360
RPFEXIT   BSS       0                                                   LEP81370
          SA5       FET                                                 LEP81380
          EQ        PFMEXIT+1                                           LEP81390
PFMEXIT   BSS       0                                                   LEP81400
          IFEQ      OS,SCOPE                                            LEP81410
          SA5       FDB            FETCH BASE WORD               (SCOPE)LEP81420
          ELSE                                                          LEP81430
          SA5       FET            FETCH BASE WORD                 (NOS)LEP81440
          ENDIF                                                         LEP81450
+         BX7       X2                                                  LEP81460
          MX0       -9D                                                 LEP81470
          SA7       PFMRET         STORE RETURN                         LEP81480
          AX5       9D                                                  LEP81490
          BX6       -X0*X5         ISOLATE RETURN CODE                  LEP81500
          SA6       STATUS         PLACE RC IN STATUS WORD              LEP81510
          ZR        X6,PFMRET      RETURN IF RC = 0                     LEP81520
          SA5       =10HFAC STATUS                                      LEP81530
          LX1       X6                                                  LEP81540
          BX7       X5                                                  LEP81550
          SA7       ASTMSG+1                                            LEP81560
          RJ        =XNCOCTL$      ENCODE STATUS IN (X6)                LEP81570
          SA6       ASTMSG+2       STORE IT                             LEP81580
          RJ        =XIOMESSG      PRINT STATUS MESSAGE                 LEP81590
PFMRET    BSS       1              RETURN TO CALLING PROGRAM            LEP81600
*                                                                       LEP81610
          IFEQ      OS,NOS                                              LEP81620
CTW       BSSZ      1              FILE CATEGORY WORD              (NOS)LEP81630
UNW       BSSZ      1              USERS NUMBER WORD               (NOS)LEP81640
RJUNW     BSSZ      1                                              (NOS)LEP81650
AMW       BSSZ      1              ACCESS MODE WORD                (NOS)LEP81660
          ENDIF                                                         LEP81670
          END                                                           LEP81680
*DECK       IOMPRT                                                      LEP81690
C=DECK      IOMPRT      IOMPRT      SUBROUTINE                          LEP81700
      SUBROUTINE    IOM PRT                                             LEP81710
C                                                                       LEP81720
C=PURPOSE   COLLECTION OF DISPLAY PROCEDURES SUPPORTING DMGASP/CDC      LEP81730
C=AUTHOR    C. A. FELIPPA                                               LEP81740
C=VERSION   JUNE 1977                                                   LEP81750
C=EQUIPMENT CDC                                                         LEP81760
C=KEYWORDS  AUXILIARY   STORAGE     MANAGER     I/O         DATA        LEP81770
C=KEYWORDS  PRINT       DISPLAY     OUTPUT                              LEP81780
C=EASY-SUB  LFNBF                                                       LEP81790
C                                                                       LEP81800
C                                                                       LEP81810
C                   C O M M O N                                         LEP81820
C                                                                       LEP81830
C=PROCEDURE IOMCOM      CDMERR      CDMETS                              LEP81840
*CALL               IOMCOM                                              LEP81850
*CALL               DMECOM                                              LEP81860
      COMMON /CDMPAD/                                                   LEP81870
     $    CMSIZ,    BCSIZ,    REQCM,    LWAREC,   PAD(192)              LEP81880
      INTEGER       CMSIZ,    BCSIZ,    REQCM,    PAD                   LEP81890
C                                                                       LEP81900
C                   T Y P E   A N D   D I M E N S I O N                 LEP81910
C                                                                       LEP81920
      INTEGER       DEVDAT(12),EQCODE,  FET(12)                         LEP81930
      INTEGER       ERRMSG(2,12)                                        LEP81940
      INTEGER       PFNDAT(3),TABFMT(7)                                 LEP81950
C                                                                       LEP81960
C                   E Q U I V A L E N C E                               LEP81970
C                                                                       LEP81980
      EQUIVALENCE   (FET,ASTPKT(14))                                    LEP81990
      EQUIVALENCE   (DEVDAT,PAD(65)), (PFNDAT,PAD(77)), (TABFMT,PAD(81))LEP82000
      EQUIVALENCE   (IOERCD,ASTOSD(2))                                  LEP82010
      EQUIVALENCE   (LDIX,DEVDAT(1)), (EQCODE,DEVDAT(3))                LEP82020
C                                                                       LEP82030
C                   D A T A                                             LEP82040
C                                                                       LEP82050
      DATA          ASTOSD(1) /1H /                                     LEP82060
      DATA          ASTMSG /6H0+++  ,8*1H /                             LEP82070
      DATA          ERRMSG /2*1H ,    10HILLEGAL DE,10HVICE INDEX,      LEP82080
     $    10HINACTIVE D,10HEVICE REF ,10HFILE AINT ,10HATTACHED  ,      LEP82090
     $    10HILLEGAL TA,10HPE POSTION,10HILLEGAL MS,10H POSITION ,      LEP82100
     $    10HILLEGAL RE,10HCORD SIZE ,10HILLEGAL RE,10HAD REQUEST,      LEP82110
     $    10HDEVICE OVE,10HRFLOW     ,10HILLEGAL WR,10HITE REQUST,      LEP82120
     $    10HMISCELL. I,10H/O ERROR  ,10HO/S CANT H,10HONOR REQST /     LEP82130
C                                                                       LEP82140
C                   L O G I C                                           LEP82150
C                                                                       LEP82160
C=ENTRY     IOMOSD      IOMOSD      ENTRY                               LEP82170
C=PURPOSE   PRINT OPERATION STATUS DESCRIPTORS (OSD)                    LEP82180
C=USAGE     INTERNAL USE BY DMGASP/CDC                                  LEP82190
C                                                                       LEP82200
C     +++++++++++++++++++++                                             LEP82210
      ENTRY         IOM OSD                                             LEP82220
C     +++++++++++++++++++++                                             LEP82230
C                                                                       LEP82240
      PRINT 10,     ASTOSD(1),ASTOSD(2),ERRMSG(1,IOERCD+1),             LEP82250
     $              ERRMSG(2,IOERCD+1),(ASTOSD(J),J=3,14)               LEP82260
   10 FORMAT (16H0+++  LAST OP = A6,13H,  ERROR CODEI4/6X2A10/6X,73HDEVILEP82270
     $CE  TYPEX LCARG1 LCARG2 LOCDEV SIZREC RET/EOI STATUS DTERR/RSC NWRLEP82280
     $DXF  /5X4I7,1XO6,I7,1XO3,I4,5XO2,4XO2,2XO2,I7)                    LEP82290
      RETURN                                                            LEP82300
C                                                                       LEP82310
C=ENTRY     IOMFET      IOMFET      ENTRY                               LEP82320
C=PURPOSE   PRINT FILE ENVIRONMENT TABLE (FET) AREA                     LEP82330
C=USAGE     INTERNAL USE BY DMGASP/CDC                                  LEP82340
C                                                                       LEP82350
C     +++++++++++++++++++++                                             LEP82360
      ENTRY         IOM FET                                             LEP82370
C     +++++++++++++++++++++                                             LEP82380
C                                                                       LEP82390
      LFNAME =   LFNBF(FET)                                             LEP82400
      PRINT 12,     LFNAME,(FET(J),J=1,10)                              LEP82410
   12 FORMAT (/22H +++  F.E.T. OF FILE  ,A7/                            LEP82420
     A   6X,7HFET+0 = O21,10X,7HFET+1 = O21 / 6X,7HFET+2 = O21,         LEP82430
     B  10X,7HFET+3 = O21 / 6X,7HFET+4 = O21,10X,7HFET+5 = O21/         LEP82440
     C   6X,7HFET+6 = O21,10X,7HFET+7 = O21 / 6X,7HFET+8 = O21,         LEP82450
     D  10X,7HFETEXT= O21 )                                             LEP82460
      RETURN                                                            LEP82470
      ENTRY         IOMFETX                                             LEP82480
      PRINT 13,     (J,ASTPKT(J),J=1,12)                                LEP82490
   13 FORMAT (/(6X,7HASTPKT(I2,3H)= O6,6X,7HASTPKT(I2,3H)= O6,6X,       LEP82500
     $    7HASTPKT(I2,3H)= O6,6X,7HASTPKT(I2,3H)= O6))                  LEP82510
      RETURN                                                            LEP82520
C                                                                       LEP82530
C=ENTRY     IOMTAB      IOMTAB      ENTRY                               LEP82540
C=PURPOSE   PRINT AUXILIARY STORAGE TABLE (AST)                         LEP82550
C=USAGE     INTERNAL USE BY DMGASP/CDC                                  LEP82560
C                                                                       LEP82570
C     +++++++++++++++++++++                                             LEP82580
      ENTRY         IOM TAB                                             LEP82590
C     +++++++++++++++++++++                                             LEP82600
C                                                                       LEP82610
      PRINT 14                                                          LEP82620
   14 FORMAT (/1X,71(1H+) /2H +11X, 47HA U X I L I A R Y    S T O R A G LEP82630
     $E    T A B L E,11X,1H+/1X,71(1H+)/1X,1H+69X1H+/72H + LDI  LFN     LEP82640
     $ EQC TYP OPT SEC  CDLOC   NEXT  LIMIT     READ WRITTEN +)         LEP82650
      ASTCNT(1) =  0                                                    LEP82660
      ASTCNT(2) =  0                                                    LEP82670
      DO 1800  J = 1,ASTDIM                                             LEP82680
        LDIX =     J                                                    LEP82690
        EQCODE =   ASTEQC(J)                                            LEP82700
        IF (EQCODE .EQ. 0)             GO TO 1800                       LEP82710
        CALL        IOM LDIX                                            LEP82720
        PRINT TABFMT,         DEVDAT                                    LEP82730
        IF (PFNDAT(1) .NE. 0)          PRINT 16, PFNDAT                 LEP82740
 1800   CONTINUE                                                        LEP82750
   16 FORMAT (8H + (PFN= A7,5H, CY=I2,6H, ID= R8,1H),34X,1H+)           LEP82760
C                                                                       LEP82770
      PRINT 18,     ASTCNT                                              LEP82780
   18 FORMAT (2H +69X1H+ /2H + I21,17H ACTIVE DEVICES (I2,6H FULL)      LEP82790
     A 23X 1H+/2H + I6, 8H TP-OPS, I6,8H WRITES, I6,7H READS,           LEP82800
     B I8,1H/I8,12H WORDS XFD + /1X 71(1H+) /)                          LEP82810
      RETURN                                                            LEP82820
C                                                                       LEP82830
C=ENTRY     IOMESS      IOMESS      ENTRY                               LEP82840
C=PURPOSE   PRINT ASTMSG (MESSAGE) ARRAY                                LEP82850
C=USAGE     INTERNAL USE BY DMGASP/CDC AND SUBPROCESSORS                LEP82860
C                                                                       LEP82870
C     +++++++++++++++++++++                                             LEP82880
      ENTRY         IOMESSG                                             LEP82890
C     +++++++++++++++++++++                                             LEP82900
C                                                                       LEP82910
C                                                                       LEP82920
      PRINT 25,      (ASTMSG(J),J=1,7)                                  LEP82930
   25 FORMAT (A6,6A10)                                                  LEP82940
      ASTMSG(1) = 6H +++                                                LEP82950
      ASTMSG(2) = 1H                                                    LEP82960
      ASTMSG(3) = 1H                                                    LEP82970
      ASTMSG(4) = 1H                                                    LEP82980
      ASTMSG(5) = 1H                                                    LEP82990
      ASTMSG(6) = 1H                                                    LEP83000
      ASTMSG(7) = 1H                                                    LEP83010
      RETURN                                                            LEP83020
C                                                                       LEP83030
C=ENTRY     PADPRT      PADPRT      ENTRY                               LEP83040
C=PURPOSE   DISPLAY CONTENTS OF CDMPAD COMMON BLOCK                     LEP83050
C=USAGE     FOR DMGASP DEBUG PRINT ONLY                                 LEP83060
C                                                                       LEP83070
C     +++++++++++++++++++++                                             LEP83080
      ENTRY         PADPRT                                              LEP83090
C     +++++++++++++++++++++                                             LEP83100
C                                                                       LEP83110
      PRINT 32,     CMSIZ,BCSIZ,REQCM,LWAREC, (PAD(J),J=1,64)           LEP83120
   32 FORMAT (/6X,8HCMSIZ = O6,10H, BCSIZ = O6,10H, REQCM = O6,         LEP83130
     $ 11H, LWAREC = O6, 17H, PAD/SAVE AREA&  /(2X,6O21))               LEP83140
 5000 CONTINUE                                                          LEP83150
      RETURN                                                            LEP83160
      END                                                               LEP83170
